├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── description.text ├── docs ├── Makefile ├── bibliography.bib ├── bibliography.html ├── bibliography_bib.html ├── index.html ├── num-utils.epub ├── num-utils.info ├── num-utils.info-1 ├── num-utils.info-2 ├── num-utils.pdf └── num-utils.texi ├── num-utils.asd ├── src ├── arithmetic.lisp ├── chebyshev.lisp ├── elementwise.lisp ├── extended-real.lisp ├── interval.lisp ├── log-exp.lisp ├── matrix-shorthand.lisp ├── matrix.lisp ├── num=.lisp ├── old │ ├── arithmetic-type.lisp │ ├── bins.lisp │ ├── conditions.lisp │ ├── differentiation.lisp │ ├── interaction.lisp │ ├── misc.lisp │ ├── optimization.lisp │ ├── pretty.lisp │ ├── sparse-array.lisp │ └── unused.lisp ├── pkgdcl.lisp ├── polynomial.lisp ├── print-matrix.lisp ├── quadrature.lisp ├── rootfinding.lisp ├── test-utilities.lisp └── utilities.lisp └── tests ├── arithmetic.lisp ├── chebyshev.lisp ├── elementwise.lisp ├── extended-real.lisp ├── interval.lisp ├── log-exp.lisp ├── main.lisp ├── matrix-shorthand.lisp ├── matrix.lisp ├── num=.lisp ├── old ├── arithmetic.lisp ├── array.lisp ├── bins.lisp ├── data-frame.lisp ├── differentiation.lisp ├── interactions.lisp ├── sub.lisp ├── test-utilities.lisp └── utilities.lisp ├── polynomial.lisp ├── quadrature.lisp ├── rootfinding.lisp ├── test-package.lisp └── utilities.lisp /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # How to Contribute 2 | 3 | We'd love to accept your patches and contributions to this project. There are 4 | just a few small guidelines you need to follow. 5 | 6 | ## Contributor License Agreement 7 | 8 | Contributions to this project must be accompanied by a Contributor License 9 | Agreement. You (or your employer) retain the copyright to your contribution; 10 | this simply gives us permission to use and redistribute your contributions as 11 | part of the project. 12 | 13 | You generally only need to submit a CLA once, so if you've already submitted one 14 | (even if it was for a different project), you probably don't need to do it 15 | again. 16 | 17 | ## The Contribution Process 18 | 19 | The basic workflow is: 20 | 21 | 1. Fork the Project 22 | 2. Create your Feature Branch (`git checkout -b feature/AmazingFeature`) 23 | 3. Commit your Changes (`git commit -m 'Add some AmazingFeature'`) 24 | 4. Push to the Branch (`git push origin feature/AmazingFeature`) 25 | 5. Open a Pull Request 26 | 27 | With multiple contributors and the desire to maintain high quality 28 | code, we need a small bit of process. For example all submissions, 29 | including submissions by project members, require review. We use 30 | GitHub pull requests for this purpose. Consult [GitHub 31 | Help](https://help.github.com/articles/about-pull-requests/) for more 32 | information on using pull requests, and the [contributing 33 | code](https://lisp-stat.dev/docs/contributing/code/) page for more 34 | details. 35 | 36 | ## Community Guidelines 37 | 38 | This project follows a code of conduct that can be found on the 39 | [contributing](https://www.lisp-stat.dev/docs/contributing/) page. 40 | 41 | ## How to contribute 42 | 43 | See the [contribution 44 | guidelines](https://www.lisp-stat.dev/docs/contributing/) 45 | in the Lisp-Stat user guide. 46 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Microsoft Public License (MS-PL) 2 | 3 | This license governs use of the accompanying software. If you use the 4 | software, you accept this license. If you do not accept the license, do not 5 | use the software. 6 | 7 | 1. Definitions 8 | The terms "reproduce," "reproduction," "derivative works," and "distribution" 9 | have the same meaning here as under U.S. copyright law. A "contribution" is 10 | the original software, or any additions or changes to the software. A 11 | "contributor" is any person that distributes its contribution under this 12 | license. "Licensed patents" are a contributor's patent claims that read 13 | directly on its contribution. 14 | 15 | 2. Grant of Rights 16 | (A) Copyright Grant- Subject to the terms of this license, including the 17 | license conditions and limitations in section 3, each contributor grants 18 | you a non-exclusive, worldwide, royalty-free copyright license to 19 | reproduce its contribution, prepare derivative works of its contribution, 20 | and distribute its contribution or any derivative works that you create. 21 | 22 | (B) Patent Grant- Subject to the terms of this license, including the 23 | license conditions and limitations in section 3, each contributor grants 24 | you a non-exclusive, worldwide, royalty-free license under its licensed 25 | patents to make, have made, use, sell, offer for sale, import, and/or 26 | otherwise dispose of its contribution in the software or derivative works 27 | of the contribution in the software. 28 | 29 | 3. Conditions and Limitations 30 | (A) No Trademark License- This license does not grant you rights to use 31 | any contributors' name, logo, or trademarks. 32 | 33 | (B) If you bring a patent claim against any contributor over patents that 34 | you claim are infringed by the software, your patent license from such 35 | contributor to the software ends automatically. 36 | 37 | (C) If you distribute any portion of the software, you must retain all 38 | copyright, patent, trademark, and attribution notices that are present in 39 | the software. 40 | 41 | (D) If you distribute any portion of the software in source code form, 42 | you may do so only under this license by including a complete copy of 43 | this license with your distribution. If you distribute any portion of the 44 | software in compiled or object code form, you may only do so under a 45 | license that complies with this license. 46 | 47 | (E) The software is licensed "as-is." You bear the risk of using it. The 48 | contributors give no express warranties, guarantees, or conditions. You 49 | may have additional consumer rights under your local laws which this 50 | license cannot change. To the extent permitted under your local laws, the 51 | contributors exclude the implied warranties of merchantability, fitness 52 | for a particular purpose and non-infringement. 53 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | [![Contributors][contributors-shield]][contributors-url] 5 | [![Forks][forks-shield]][forks-url] 6 | [![Stargazers][stars-shield]][stars-url] 7 | [![Issues][issues-shield]][issues-url] 8 | [![MS-PL License][license-shield]][license-url] 9 | [![LinkedIn][linkedin-shield]][linkedin-url] 10 | 11 | 12 | 13 | 14 |
15 |

16 | 17 | Logo 18 | 19 | 20 |

Numerical Utilities

21 | 22 |

23 | For statistical computing and numerical methods 24 |
25 | Explore the docs » 26 |
27 |
28 | Report Bug 29 | · 30 | Request Feature 31 | · 32 | Reference Manual 33 |

34 |

35 | 36 | 37 | 38 | 39 |
40 |

Table of Contents

 41 |
    42 |
  1. 43 | About The Project 44 | 47 |
    2. 48 |
  2. 49 | Getting Started 50 | 54 |
    3. 55 |
  3. Usage
    4. 56 |
  4. Roadmap
    5. 57 |
  5. Resources
    6. 58 |
  6. Contributing
    7. 59 |
  7. License
    8. 60 |
  8. Contact
    9. 61 |
62 |
63 | 64 | 65 | 66 | 67 | ## About the Project 68 | 69 | This library is a collection of packages useful in numerical 70 | applications, each big enough to be its own package, but too small 71 | to split out into a separate ASDF system. Included are: 72 | 73 | - `num=`, a comparison operator for floats 74 | - simple arithmetic functions, like `sum` and `l2norm` 75 | - element-wise operations for arrays and vectors 76 | - intervals 77 | - special matrices and shorthand for their input 78 | - sample statistics 79 | - Chebyshev polynomials 80 | - quadratures 81 | - univariate root finding 82 | 83 | 84 | ### Built With 85 | 86 | * [anaphora](https://github.com/tokenrove/anaphora) 87 | * [alexandria](https://gitlab.common-lisp.net/alexandria/alexandria) 88 | * [array-operations](https://github.com/bendudson/array-operations) 89 | * [select](https://github.com/Symbolics/select) 90 | * [let-plus](https://github.com/sharplispers/let-plus) 91 | 92 | 93 | 94 | ## Getting Started 95 | 96 | To get a local copy up and running follow these steps: 97 | 98 | ### Prerequisites 99 | 100 | An ANSI Common Lisp implementation. Developed and tested with 101 | [SBCL](http://www.sbcl.org/) ~~and 102 | [CCL](https://github.com/Clozure/ccl)~~. 103 | 104 | #### Installation 105 | 106 | To make the system accessible to [ASDF](https://common-lisp.net/project/asdf/) (a build facility, similar to `make` in the C world), clone the repository in a directory ASDF knows about. By default the `common-lisp` directory in your home directory is known. Create this if it doesn't already exist and then: 107 | 108 | 1. Clone the repositories 109 | ```sh 110 | cd ~/common-lisp && \ 111 | git clone https://github.com/Lisp-Stat/numerical-utilities.git && \ 112 | git clone https://gitlab.common-lisp.net/alexandria/alexandria.git && \ 113 | git clone https://github.com/tokenrove/anaphora.git && \ 114 | git clone https://github.com/Lisp-Stat/array-operations.git && \ 115 | git clone https://github.com/Lisp-Stat/select && \ 116 | git clone https://github.com/sharplispers/let-plus.git 117 | ``` 118 | 119 | 2. From the REPL reset the ASDF source-registry to find the new systems: 120 | ```lisp 121 | (asdf:clear-source-registry) 122 | ``` 123 | 3. Load the system 124 | ```lisp 125 | (asdf:load-system :num-utils) 126 | ``` 127 | 128 | If you have installed the slime ASDF extensions, you can invoke this 129 | with a comma (',') from the slime REPL. 130 | 131 | #### Getting dependencies 132 | 133 | To get the third party systems that these system may depend on, you can use a dependency manager, such as [Quicklisp](https://www.quicklisp.org/beta/) or [CLPM](https://www.clpm.dev/) Once installed, get the dependencies with either of: 134 | 135 | ```lisp 136 | (clpm-client:sync :sources "clpi") ;sources may vary 137 | ``` 138 | 139 | ```lisp 140 | (ql:quickload :num-utils) 141 | ``` 142 | 143 | You need do this only once. After obtaining the dependencies, you can 144 | load the system with `ASDF` as described above without first syncing 145 | sources. 146 | 147 | ### Documentation 148 | 149 | The API documentation is in the `docs/` directory and is available in 150 | emacs info format, PDF and HTML. You can also [view the documentation 151 | online](https://lisp-stat.github.io/numerical-utilities/). 152 | 153 | 154 | ## Usage 155 | 156 | ```lisp 157 | (nu:median '(1 2 3 4 5 6 7 8 9 10)) ; -> 11/2 158 | ``` 159 | 160 | Note a [ratio](https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node18.html) is returned. This is a feature and Lisp-Stat leverages the 161 | [Common Lisp numerical 162 | tower](https://en.wikipedia.org/wiki/Numerical_tower). 163 | 164 | For more examples, please refer to the [Reference Manual](https://lisp-stat.github.io/numerical-utilities/) 165 | 166 | 167 | 168 | ## Roadmap 169 | 170 | See the [open issues](https://github.com/lisp-stat/numerical-utilities/issues) for a list of proposed features (and known issues). 171 | 172 | 173 | ## Origin 174 | 175 | This library is a fork of 176 | [cl-num-utils](https://github.com/tpapp/cl-num-utils). Changes include: 177 | 178 | 1. Make work with Genera 179 | 2. Convert to [fiveam](https://github.com/sionescu/fiveam) for unit 180 | tests ([clunit](https://github.com/tgutu/clunit) seems abandoned) 181 | 3. Restore quadrature tests 182 | 4. Fix SBCL compiler warnings 183 | 184 | Although the project has been renamed to distinguish it from the 185 | original, the package names are the same and should work as a drop-in 186 | replacement. 187 | 188 | ## Status 189 | 190 | It appears that this library was in the midst of a reorganization when 191 | released. As near as I can tell from the [github 192 | history](https://github.com/tpapp/cl-num-utils/commit/a0f522b44b465fc071623f9662bdde0163be6467), 193 | all the files in cl-num-utils were moved to src/old/, and then 194 | selectively moved into src/ as they were cleaned up and unit tests 195 | written. Some, such as data-frame, were moved by Papp into separate 196 | projects. Several of the files in old/ could be dusted off and moved 197 | into src/ to be used. Check in data-frames project first because I think 198 | some were moved there without being removed from cl-num-utils. 199 | 200 | There was a fair amount of code commented out by the original author. 201 | Where we have commented code, we use the block comment syntax 202 | `#| ... |#`, and noted the person performing the removal. We have also 203 | added comments throughout the code to make it more readable, or to 204 | include our research notes. 205 | 206 | ## Known Issues 207 | 208 | ### Test Failures 209 | 210 | [Issue 1](https://github.com/Symbolics/num-utils/issues/1) describes a 211 | problem with the wrapped-bivariate-to-array test in tests/matrix.lisp. 212 | This fails under fiveam, but passes on clunit. I believe there to be a 213 | bug, either in fiveam or num-utils (or, possibly, clunit). The [fiveam 214 | reason-arg](https://common-lisp.net/project/fiveam/docs/api/macro_005FIT.BESE.FIVEAM_003A_003AIS.html) 215 | is misleading, it will print the two values, and they are equal. However 216 | this only happens after the *second* call. For example, given this code 217 | 218 | ``` {.commonlisp org-language="lisp"} 219 | (is (num= (funcall op a b) 220 | (funcall op (funcall convert a) b));) 221 | "Expected ~A to be equal to ~A" (funcall op a b) (funcall op (funcall convert a) b)) 222 | ``` 223 | 224 | The sequence 225 | 226 | ``` {.commonlisp org-language="lisp"} 227 | (funcall op a b) 228 | (funcall op (funcall convert a) b) 229 | ``` 230 | 231 | is called twice, once as part of the test and once as part of the 232 | reason-args output. The *first* time, the results are different. The 233 | *second* time they are the same, making it appear that the result is a 234 | false negative. It is not. 235 | 236 | This test needs to be looked into further. The test code will not win 237 | any \'most readable code of the year\' awards, and the answer is buried 238 | below several layers of macro expansions, funcalls and currying. 239 | 240 | Until this is resolved, use this function with caution. 241 | 242 | Papp\'s [issue \#16](https://github.com/tpapp/cl-num-utils/issues/16) is 243 | no longer a problem. The functionality was moved to `SELECT` (Papp\'s 244 | `CL-SLICE`). It should have been closed but was not before Papp 245 | abandoned the library. 246 | 247 | ### Implementation Support 248 | 249 | Development is primarily done with SBCL and CCL on MS Windows. Issue 250 | [papp15](https://github.com/tpapp/cl-num-utils/issues/15) reports that 251 | generic function definitions may not work on other implementations. 252 | Please report any such problems on the [Github issue 253 | tracker](https://github.com/Lisp-Stat/numerical-utilities/issues). 254 | 255 | ### Symbol conflicts with alexandria 256 | 257 | Importing both `num-utils` and `alexandria` will result in symbol 258 | conflicts. There are two solutions for this: either import only parts of 259 | `num-utils` (see the packages named in each file), or shadow some 260 | symbols, e.g. 261 | 262 | ``` {.commonlisp org-language="lisp"} 263 | (cl:defpackage #:my-package 264 | (:use #:cl 265 | #:alexandria 266 | #:num-utils) 267 | (:shadowing-import-from #:alexandria #:mean #:variance #:median)) 268 | ``` 269 | 270 | This is what the top-level `ls-user` package does. 271 | 272 | ## Resources 273 | 274 | This system is part of the [Lisp-Stat](https://lisp-stat.dev/) 275 | project; that should be your first stop for information. Also see the 276 | [resources](https://lisp-stat.dev/resources) and 277 | [community](https://lisp-stat.dev/community) pages for more 278 | information. 279 | 280 | 281 | ## Contributing 282 | 283 | Contributions are what make the open source community such an amazing place to be learn, inspire, and create. Any contributions you make are **greatly appreciated**. Please see [CONTRIBUTING.md](CONTRIBUTING.md) for details on our code of conduct, and the process for submitting pull requests. 284 | 285 | 286 | ## License 287 | 288 | Distributed under the MS-PL License. See `LICENSE` for more information. 289 | 290 | 291 | 292 | 293 | ## Contact 294 | 295 | Project Link: [https://github.com/lisp-stat/numerical-utilities](https://github.com/lisp-stat/numerical-utilities) 296 | 297 | 298 | 299 | 300 | 301 | [contributors-shield]: https://img.shields.io/github/contributors/lisp-stat/numerical-utilities.svg?style=for-the-badge 302 | [contributors-url]: https://github.com/lisp-stat/numerical-utilities/graphs/contributors 303 | [forks-shield]: https://img.shields.io/github/forks/lisp-stat/numerical-utilities.svg?style=for-the-badge 304 | [forks-url]: https://github.com/lisp-stat/numerical-utilities/network/members 305 | [stars-shield]: https://img.shields.io/github/stars/lisp-stat/numerical-utilities.svg?style=for-the-badge 306 | [stars-url]: https://github.com/lisp-stat/numerical-utilities/stargazers 307 | [issues-shield]: https://img.shields.io/github/issues/lisp-stat/numerical-utilities.svg?style=for-the-badge 308 | [issues-url]: https://github.com/lisp-stat/numerical-utilities/issues 309 | [license-shield]: https://img.shields.io/github/license/lisp-stat/numerical-utilities.svg?style=for-the-badge 310 | [license-url]: https://github.com/lisp-stat/numerical-utilities/blob/master/LICENSE 311 | [linkedin-shield]: https://img.shields.io/badge/-LinkedIn-black.svg?style=for-the-badge&logo=linkedin&colorB=555 312 | [linkedin-url]: https://www.linkedin.com/company/symbolics/ 313 | -------------------------------------------------------------------------------- /description.text: -------------------------------------------------------------------------------- 1 | This library implements simple numerical functions for Common Lisp, including 2 | 3 | num=, a comparison operator for floats 4 | simple arithmeric functions, like sum and l2norm 5 | elementwise operations for arrays 6 | intervals 7 | special matrices and shorthand for their input 8 | sample statistics 9 | Chebyshev polynomials 10 | univariate rootfinding 11 | -------------------------------------------------------------------------------- /docs/Makefile: -------------------------------------------------------------------------------- 1 | bibliography.html: bibliography.bib 2 | bibtex2html $< 3 | -------------------------------------------------------------------------------- /docs/bibliography.bib: -------------------------------------------------------------------------------- 1 | @article{pebay2008formulas, 2 | title={Formulas for robust, one-pass parallel computation of covariances and arbitrary-order statistical moments}, 3 | author={P{\'e}bay, P.}, 4 | journal={Sandia Report SAND2008-6212, Sandia National Laboratories}, 5 | year={2008} 6 | } 7 | 8 | @inproceedings{bennett2009numerically, 9 | title={Numerically stable, single-pass, parallel statistics algorithms}, 10 | author={Bennett, J. and Grout, R. and P{\'e}bay, P. and Roe, D. and Thompson, D.}, 11 | booktitle={Cluster Computing and Workshops, 2009. CLUSTER'09. IEEE International Conference on}, 12 | pages={1--8}, 13 | year={2009}, 14 | organization={IEEE} 15 | } 16 | -------------------------------------------------------------------------------- /docs/bibliography.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | bibliography 7 | 8 | 9 | 10 | 11 | 12 | 13 | 17 | 18 | 19 | 20 | 21 | 22 | 25 | 34 | 35 | 36 | 37 | 38 | 41 | 49 | 50 |
23 | [1] 24 | 26 | P. Pébay. 27 | Formulas for robust, one-pass parallel computation of covariances and 28 | arbitrary-order statistical moments. 29 | Sandia Report SAND2008-6212, Sandia National Laboratories, 30 | 2008. 31 | [ bib ] 32 | 33 |
39 | [2] 40 | 42 | J. Bennett, R. Grout, P. Pébay, D. Roe, and D. Thompson. 43 | Numerically stable, single-pass, parallel statistics algorithms. 44 | In Cluster Computing and Workshops, 2009. CLUSTER'09. IEEE 45 | International Conference on, pages 1-8. IEEE, 2009. 46 | [ bib ] 47 | 48 |

This file was generated by 51 | bibtex2html 1.97.

52 | 53 | 54 | -------------------------------------------------------------------------------- /docs/bibliography_bib.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | bibliography.bib 7 | 8 | 9 | 10 | 11 | 12 |

bibliography.bib

13 | @article{pebay2008formulas,
14 |   title = {Formulas for robust, one-pass parallel computation of covariances and arbitrary-order statistical moments},
15 |   author = {P{\'e}bay, P.},
16 |   journal = {Sandia Report SAND2008-6212, Sandia National Laboratories},
17 |   year = {2008}
18 | }
19 |
20 | 21 | 
22 | @inproceedings{bennett2009numerically,
23 |   title = {Numerically stable, single-pass, parallel statistics algorithms},
24 |   author = {Bennett, J. and Grout, R. and P{\'e}bay, P. and Roe, D. and Thompson, D.},
25 |   booktitle = {Cluster Computing and Workshops, 2009. CLUSTER'09. IEEE International Conference on},
26 |   pages = {1--8},
27 |   year = {2009},
28 |   organization = {IEEE}
29 | }
30 |
31 | 32 |

This file was generated by 33 | bibtex2html 1.97.

34 | 35 | 36 | -------------------------------------------------------------------------------- /docs/num-utils.epub: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Lisp-Stat/numerical-utilities/10f1d83ac44ce992e06c667d74b49263ac8ede55/docs/num-utils.epub -------------------------------------------------------------------------------- /docs/num-utils.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Lisp-Stat/numerical-utilities/10f1d83ac44ce992e06c667d74b49263ac8ede55/docs/num-utils.pdf -------------------------------------------------------------------------------- /num-utils.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: ASDF -*- 2 | ;;; Copyright (c) 2010 by Tamas K. Papp 3 | ;;; Copyright (c) 2019-2023 by Symbolics Pte. Ltd. All rights reserved. 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | (defsystem "num-utils" 7 | :version "1.6.1" 8 | :license :MS-PL 9 | :author "Steven Nunez " 10 | :long-name "Numerical Utilities" 11 | :description "Numerical utilities for Common Lisp" 12 | :long-description #.(uiop:read-file-string 13 | (uiop:subpathname *load-pathname* "description.text")) 14 | ;:homepage "https://lisp-stat.dev/docs/tasks/plotting/" 15 | :source-control (:git "https://github.com/Lisp-Stat/numerical-utilities.git") 16 | :bug-tracker "https://github.com/Lisp-Stat/numerical-utilities/issues" 17 | :depends-on (#:anaphora 18 | #:alexandria 19 | #:alexandria+ 20 | #:array-operations 21 | #:select 22 | #:let-plus) 23 | :in-order-to ((test-op (test-op "num-utils/tests"))) 24 | :pathname "src/" 25 | :serial t 26 | :components ((:file "utilities") 27 | (:file "arithmetic") 28 | (:file "num=") 29 | (:file "extended-real") 30 | (:file "interval") 31 | (:file "chebyshev") 32 | (:file "polynomial") 33 | (:file "elementwise") 34 | (:file "print-matrix") 35 | (:file "matrix") 36 | (:file "matrix-shorthand") 37 | (:file "quadrature") 38 | (:file "rootfinding") 39 | (:file "log-exp") 40 | (:file "test-utilities") 41 | (:file "pkgdcl"))) 42 | 43 | (defsystem "num-utils/tests" 44 | :version "1.0.0" 45 | :description "Unit tests for NUM-UTILS." 46 | :author "Steven Nunez " 47 | :license "Same as NUM-UTILS -- this is part of the NUM-UTILS library." 48 | #+asdf-unicode :encoding #+asdf-unicode :utf-8 49 | :depends-on (#:num-utils 50 | #:fiveam 51 | #:select) ; matrix test needs this 52 | :pathname "tests/" 53 | :serial t 54 | :components 55 | ((:file "test-package") 56 | (:file "main") 57 | ;; in alphabetical order 58 | (:file "arithmetic") 59 | ;; (:file "arithmetic-type") ; No tests included in Papp's version 60 | (:file "chebyshev") 61 | (:file "polynomial") 62 | (:file "elementwise") 63 | (:file "extended-real") 64 | (:file "interval") 65 | (:file "matrix") 66 | (:file "matrix-shorthand") 67 | (:file "num=") 68 | (:file "quadrature") 69 | (:file "rootfinding") 70 | (:file "log-exp") 71 | (:file "utilities")) 72 | :perform (test-op (o s) 73 | (uiop:symbol-call :fiveam :run! 74 | (uiop:find-symbol* :all-tests 75 | :num-utils-tests)))) 76 | -------------------------------------------------------------------------------- /src/arithmetic.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.ARITHMETIC -*- 2 | ;;; Copyright (c) 2011-2014 Tamas Papp 3 | ;;; Copyright (c) 2023 Symbolics Pte Ltd 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | ;;; simple arithmetic 7 | 8 | (uiop:define-package #:num-utils.arithmetic 9 | (:use #:cl 10 | #:alexandria-2 11 | #:alexandria+ 12 | #:anaphora 13 | #:num-utils.utilities 14 | #:let-plus) 15 | (:export 16 | #:same-sign-p 17 | #:square 18 | #:cube 19 | #:absolute-square 20 | #:abs-diff 21 | #:log10 22 | #:log2 23 | #:1c 24 | #:divides? 25 | #:as-integer 26 | #:numseq 27 | #:ivec 28 | #:sum 29 | #:product 30 | #:cumulative-sum 31 | #:cumulative-product 32 | #:normalize-probabilities 33 | #:floor* 34 | #:ceiling* 35 | #:round* 36 | #:truncate* 37 | #:seq-max 38 | #:seq-min)) 39 | (in-package #:num-utils.arithmetic) 40 | 41 | (defun same-sign-p (&rest arguments) 42 | "Test whether all arguments have the same sign (ie all are positive, negative, or zero)." 43 | (if arguments 44 | (let+ (((first . rest) arguments) 45 | (sign (signum first))) 46 | (every (lambda (number) (= sign (signum number))) rest)) 47 | t)) 48 | 49 | (declaim (inline square)) 50 | (defun square (number) 51 | "Square of number." 52 | (expt number 2)) 53 | 54 | (declaim (inline cube)) 55 | (defun cube (number) 56 | "Cube of number." 57 | (expt number 3)) 58 | 59 | (declaim (inline absolute-square)) 60 | (defun absolute-square (number) 61 | "Number multiplied by its complex conjugate." 62 | (* (conjugate number) number)) 63 | 64 | (declaim (inline abs-diff)) 65 | (defun abs-diff (a b) 66 | "Absolute difference of A and B." 67 | (abs (- a b))) 68 | 69 | ;;; Aliases for commonly used log bases. 70 | ;;; Why logarithms? The CL spec lets `log' return a single float for 71 | ;;; an integer argument, which is not what we want. 72 | (declaim (inline log10 log2 ln)) 73 | 74 | (defun log10 (number) 75 | "Abbreviation for decimal logarithm." 76 | (log number 10d0)) 77 | 78 | (defun log2 (number) 79 | "Abbreviation for binary logarithm." 80 | (log number 2d0)) 81 | 82 | (defun ln (n) 83 | "Natural logarithm." 84 | (log n (exp 1d0))) 85 | 86 | 87 | (declaim (inline 1c)) 88 | (defun 1c (number) 89 | "Return 1-number. The mnemonic is \"1 complement\", 1- is already a CL library function." 90 | (- 1 number)) 91 | 92 | (defun divides? (number divisor) 93 | "Test if DIVISOR divides NUMBER without remainder, and if so, return the 94 | quotient. Works generally, but makes most sense for rationals." 95 | (let+ (((&values quot rem) (floor number divisor))) 96 | (when (zerop rem) 97 | quot))) 98 | 99 | (defun as-integer (number) 100 | "If NUMBER represents an integer (as an integer, complex, or float, etc), return it as an integer, otherwise signal an error. Floats are converted with RATIONALIZE." 101 | (declare (inline as-integer)) 102 | (typecase number 103 | (integer number) 104 | (complex 105 | (assert (zerop (imagpart number)) () 106 | "~A has non-zero imaginary part." number) 107 | (as-integer (realpart number))) 108 | (t (aprog1 (rationalize number) 109 | (assert (integerp it) () "~A has non-zero fractional part." number))))) 110 | 111 | 112 | ;;; arithmetic sequences 113 | 114 | (defun seq-min (x) 115 | "Return the minimum value in the sequence X" 116 | (check-type x alexandria:proper-sequence) 117 | (cond ((listp x) (apply 'min x)) 118 | ((vectorp x) (reduce #'min x)))) 119 | 120 | (defun seq-max (x) 121 | "Return the maximum value in the sequence X" 122 | (check-type x alexandria:proper-sequence) 123 | (cond ((listp x) (apply 'max x)) 124 | ((vectorp x) (reduce #'max x)))) 125 | 126 | (defun numseq (from to &key length (by (unless length 1)) type) 127 | "Return a sequence between FROM and TO, progressing by BY, of the given LENGTH. Only 3 of these a parameters should be given, the missing one (NIL) should be inferred automatically. The sign of BY is adjusted if necessary. If TYPE is LIST, the result is a list, otherwise it determines the element type of the resulting simple array. If TYPE is nil, it as autodetected from the arguments (as a FIXNUM, a RATIONAL, or some subtype of FLOAT). Note that the implementation may upgrade the element type." 128 | (flet ((seq% (from by length) 129 | (if (eq type 'list) 130 | (loop 131 | for i :from 0 :below length 132 | collecting (+ from (* i by))) 133 | (let+ ((type (cond 134 | (type type) 135 | ((= length 1) (if (typep from 'fixnum) 136 | 'fixnum 137 | (type-of from))) 138 | (t (let ((to (+ from (* by length)))) 139 | (typecase to 140 | (fixnum (if (typep from 'fixnum) 141 | 'fixnum 142 | 'integer)) 143 | (float (type-of to)) 144 | (t 'rational)))))) 145 | (result (make-array length :element-type type))) 146 | (dotimes (i length) 147 | (setf (aref result i) (coerce (+ from (* i by)) type))) 148 | result)))) 149 | (cond 150 | ((not from) 151 | (seq% (- to (* by (1- length))) by length)) 152 | ((not to) 153 | (seq% from by length)) 154 | ((not length) 155 | (assert (not (zerop by))) 156 | (let* ((range (- to from)) 157 | (by (* (signum range) (signum by) by)) 158 | (length (1+ (floor (/ range by))))) 159 | (seq% from by length))) 160 | ((and length (not by)) 161 | (let ((range (- to from))) 162 | (seq% from (if (zerop range) 163 | 0 164 | (/ range (1- length))) 165 | length))) 166 | (t (error "Only 3 of FROM, TO, LENGTH and BY are needed."))))) 167 | 168 | (defun ivec (end-or-start &optional (end 0 end?) (by 1) strict-direction?) 169 | "Return a vector of fixnums. 170 | 171 | (ivec end) => #(0 ... end-1) (or #(0 ... end+1) when end is negative). 172 | 173 | (ivec start end) => #(start ... end-1) or to end+1 when end is negative. 174 | 175 | When BY is given it determines the increment, adjusted to match the direction unless STRICT-DIRECTION, in which case an error is signalled. " 176 | (check-types (end-or-start end by) fixnum) 177 | (if end? 178 | (let* ((abs-by (abs by)) 179 | (start end-or-start) 180 | (diff (- end start)) 181 | (length (ceiling (abs diff) abs-by)) 182 | (by (aprog1 (* abs-by (signum diff)) 183 | (when strict-direction? 184 | (assert (= it by) () "BY does not match direction.")))) 185 | (element start)) 186 | (aprog1 (make-array length :element-type 'fixnum) 187 | (loop for index below length 188 | do (setf (aref it index) element) 189 | (incf element by)))) 190 | (let* ((end end-or-start) 191 | (abs-end (abs end))) 192 | (aprog1 (make-array abs-end :element-type 'fixnum) 193 | (if (plusp end) 194 | (loop for index below abs-end 195 | do (setf (aref it index) index)) 196 | (loop for index below abs-end 197 | do (setf (aref it index) (- index)))))))) 198 | 199 | ;;; sums and products 200 | 201 | (defgeneric sum (object &key key) 202 | (:documentation "Sum of elements in object. KEY is applied to each element.") 203 | (:method ((sequence sequence) &key (key #'identity)) 204 | (reduce #'+ sequence :key key)) 205 | (:method ((array array) &key (key #'identity)) 206 | (reduce #'+ (aops:flatten array) :key key))) 207 | 208 | (defgeneric product (object) 209 | (:documentation "Product of elements in object.") 210 | (:method ((sequence sequence)) 211 | (reduce #'* sequence)) 212 | (:method ((array array)) 213 | (reduce #'* (aops:flatten array)))) 214 | 215 | ;;; cumulative sum and product 216 | 217 | (defun similar-element-type (element-type) 218 | "Return a type that is a supertype of ELEMENT-TYPE and is closed under arithmetic operations. May not be the narrowest." 219 | (if (subtypep element-type 'float) 220 | element-type 221 | t)) 222 | 223 | (defun similar-sequence-type (sequence) 224 | "Return type that sequence can be mapped to using arithmetic operations." 225 | (etypecase sequence 226 | (list 'list) 227 | (vector `(simple-array 228 | ,(similar-element-type (array-element-type sequence)) (*))))) 229 | 230 | 231 | (defun cumulative-sum (sequence 232 | &key (result-type (similar-sequence-type sequence))) 233 | "Cumulative sum of sequence. Return a sequence of the same kind and length; last element is the total. The latter is returned as the second value." 234 | (let ((sum 0)) 235 | (values (map result-type (lambda (element) 236 | (incf sum element)) 237 | sequence) 238 | sum))) 239 | 240 | (defun cumulative-product (sequence 241 | &key (result-type 242 | (similar-sequence-type sequence))) 243 | "Cumulative product of sequence. Return a sequence of the same kind and length; last element is the total product. The latter is also returned as the second value." 244 | (let ((product 1)) 245 | (values (map result-type (lambda (element) 246 | (multf product element)) 247 | sequence) 248 | product))) 249 | 250 | 251 | 252 | (defun normalize-probabilities (vector 253 | &key 254 | (element-type t) 255 | (result (make-array (length vector) 256 | :element-type element-type))) 257 | "Verify that each element of VECTOR is nonnegative and return a vector multiplied so that they sum to 1. ELEMENT-TYPE can be used to specify the element-type of the result. When RESULT is given, the result is placed there. When RESULT is NIL, VECTOR is modified instead." 258 | (unless result 259 | (setf result vector) 260 | (let ((result-type (array-element-type result))) 261 | (unless (subtypep element-type result-type) 262 | (setf element-type result-type)))) 263 | (let ((result (aif result it vector)) 264 | (sum (reduce #'+ vector 265 | :key (lambda (element) 266 | (assert (non-negative-real-p element)) 267 | element)))) 268 | (map-into result (lambda (element) (coerce (/ element sum) element-type)) vector))) 269 | 270 | ;;; truncation/rounding 271 | 272 | (defmacro define-rounding-with-offset (name function docstring) 273 | `(defun ,name (number &optional (divisor 1) (offset 0)) 274 | ,docstring 275 | (let+ (((&values quotient remainder) (,function (- number offset) divisor))) 276 | (values (+ offset (* quotient divisor)) remainder)))) 277 | 278 | (define-rounding-with-offset floor* floor 279 | "Find the highest A=I*DIVISOR+OFFSET <= NUMBER, return (values A (- A NUMBER).") 280 | 281 | (define-rounding-with-offset ceiling* ceiling 282 | "Find the lowest A=I*DIVISOR+OFFSET >= NUMBER, return (values A (- A NUMBER).") 283 | 284 | (define-rounding-with-offset round* round 285 | "Find A=I*DIVISOR+OFFSET that minimizes |A-NUMBER|, return (values A (- A NUMBER). When NUMBER is exactly in between two possible A's, the rounding rule of ROUND is used on NUMBER-OFFSET.") 286 | 287 | (define-rounding-with-offset truncate* truncate 288 | "Find A=I*DIVISOR+OFFSET that maximizes |A|<=|NUMBER| with the same sign, return (values A (- A NUMBER).") 289 | -------------------------------------------------------------------------------- /src/chebyshev.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.CHEBYSHEV -*- 2 | ;;; Copyright (c) 2011-2014 Tamas Papp 3 | ;;; Copyright (c) 2023 Symbolics Pte Ltd 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | (uiop:define-package #:num-utils.chebyshev 7 | (:use #:cl 8 | #:alexandria 9 | #:anaphora 10 | #:num-utils.interval 11 | #:num-utils.utilities 12 | #:let-plus) 13 | (:export ; These should probably be renamed in verb-object form 14 | #:chebyshev-root 15 | #:chebyshev-roots 16 | #:chebyshev-regression 17 | #:evaluate-chebyshev 18 | #:chebyshev-approximate)) 19 | (in-package #:num-utils.chebyshev) 20 | 21 | (declaim (inline chebyshev-recursion)) 22 | (defun chebyshev-recursion (x value previous-value) 23 | "Chebyshev polynomial recursion formula." 24 | (- (* 2 x value) previous-value)) 25 | 26 | (declaim (inline chebyshev-root)) 27 | (defun chebyshev-root (m i) 28 | "Return the iTH root of the Mth Chebyshev polynomial as double-float." 29 | (assert (within? 0 i m)) 30 | (- (cos (/ (* (+ i 1/2) (float pi 1d0)) m)))) 31 | 32 | (defun chebyshev-roots (m) 33 | "Return the roots of the Mth Chebyshev polynomial as a vector of 34 | double-floats." 35 | (aprog1 (make-array m :element-type 'double-float) 36 | (dotimes (i m) 37 | (setf (aref it i) (chebyshev-root m i))))) 38 | 39 | (defun chebyshev-regression (f n-polynomials 40 | &optional (n-points n-polynomials)) 41 | "Chebyshev polynomial regression using the given number of polynomials and 42 | points (zeroes of the corresponding Chebyshev polynomial)." 43 | (check-types (n-polynomials n-points) positive-fixnum) 44 | (assert (<= n-polynomials n-points) () 45 | "Can't identify ~A coefficients with only ~A points." 46 | n-polynomials n-points) 47 | (locally (declare ; (optimize speed) 48 | (type positive-fixnum n-polynomials n-points)) 49 | (let+ ((z (the simple-double-float-vector (chebyshev-roots n-points))) 50 | (f-at-z (map 'simple-double-float-vector 51 | (lambda (z) (coerce (funcall f z) 'double-float)) z)) 52 | (coefficients (make-array n-points :element-type 'double-float)) 53 | (values z) 54 | previous-values 55 | ((&flet weighted-sum (values) 56 | (/ (loop for v across values 57 | for f across f-at-z 58 | summing (* f v)) 59 | (/ n-points 2))))) 60 | (declare (type simple-double-float-vector 61 | z f-at-z values previous-values)) 62 | (loop for j from 0 below n-polynomials 63 | do (setf (aref coefficients j) 64 | (if (zerop j) 65 | (/ (reduce #'+ f-at-z) n-points) 66 | (progn 67 | (cond 68 | ((= j 1) (weighted-sum z)) 69 | ((= j 2) (setf values 70 | (map 'simple-double-float-vector 71 | (lambda (z) 72 | (chebyshev-recursion z z 1d0)) 73 | z))) 74 | ((= j 3) 75 | (setf previous-values values 76 | values (map 'simple-double-float-vector 77 | #'chebyshev-recursion 78 | z previous-values z))) 79 | (t (map-into previous-values 80 | #'chebyshev-recursion z values previous-values) 81 | (rotatef values previous-values))) 82 | (weighted-sum values))))) 83 | coefficients))) 84 | 85 | (defun evaluate-chebyshev (coefficients x) 86 | "Return the sum of Chebyshev polynomials, weighted by COEFFICIENTS, at X." 87 | (let ((value (coerce x 'double-float)) 88 | (previous-value 1d0) 89 | (sum 0d0)) 90 | (dotimes (index (length coefficients)) 91 | (incf sum (* (aref coefficients index) 92 | (cond 93 | ((= index 0) 1d0) 94 | ((= index 1) x) 95 | (t (setf previous-value (chebyshev-recursion x value previous-value)) 96 | (rotatef value previous-value) 97 | value))))) 98 | sum)) 99 | 100 | 101 | 102 | (declaim (inline ab-to-cinf cinf-to-ab ab-to-cd-intercept-slope)) 103 | 104 | (defun cinf-to-ab (x a b c) 105 | "Map x in [c,plus-infinity) to z in [a,b] using x -> (x-c)/(1+x-c)+(b-a)+a." 106 | (let ((xc (- x c))) 107 | (assert (<= 0 xc) () "Value outside domain.") 108 | (+ (* (/ xc (1+ xc)) (- b a)) a))) 109 | 110 | (defun ab-to-cinf (z a b c) 111 | "Inverse of cinf-to-ab." 112 | (let ((z-norm (/ (- z a) (- b a)))) 113 | (assert (within? 0 z-norm 1) () "Value outside domain.") 114 | (+ c (/ z-norm (- 1 z-norm))))) 115 | 116 | (defun ab-to-cd-intercept-slope (a b c d) 117 | "Return (values INTERCEPT SLOPE) for linear mapping x:-> intercept+slope*x 118 | from [a,b] to [c,d]." 119 | (let ((b-a (- b a))) 120 | (values (/ (- (* b c) (* a d)) b-a) 121 | (/ (- d c) b-a)))) 122 | 123 | (defun chebyshev-approximate (f interval n-polynomials 124 | &key (n-points n-polynomials)) 125 | "Return a closure approximating F on the given INTERVAL (may be infinite on 126 | either end) using the given number of Chebyshev polynomials." 127 | (chebyshev-approximate-implementation f interval n-polynomials n-points)) 128 | 129 | (defgeneric chebyshev-approximate-implementation (f interval n-polynomials 130 | n-points) 131 | (:documentation "Implementation of CHEBYSHEV-APPROXIMATE.") 132 | (:method (f (interval plusinf-interval) n-polynomials n-points) 133 | (let+ (((&interval (left open-left?) &ign) interval) 134 | (a (if open-left? 135 | -1d0 136 | (chebyshev-root n-points 0))) 137 | (left (coerce left 'double-float)) 138 | (coefficients 139 | (chebyshev-regression (lambda (z) 140 | (funcall f (ab-to-cinf z a 1d0 left))) 141 | n-polynomials n-points))) 142 | (lambda (x) 143 | (evaluate-chebyshev coefficients (cinf-to-ab x a 1d0 left))))) 144 | (:method (f (interval finite-interval) n-polynomials n-points) 145 | (let+ (((&interval (left open-left?) (right open-right?)) interval)) 146 | (assert (< left right)) 147 | (let+ ((a (if open-left? 148 | -1d0 149 | (chebyshev-root n-points 0))) 150 | (b (if open-right? 151 | 1d0 152 | (chebyshev-root n-points (1- n-points)))) 153 | ((&values intercept slope) (ab-to-cd-intercept-slope left right a b)) 154 | (coefficients (chebyshev-regression (lambda (z) 155 | (funcall f (/ (- z intercept) 156 | slope))) 157 | n-polynomials n-points))) 158 | (lambda (x) 159 | (evaluate-chebyshev coefficients (+ intercept (* slope x)))))))) 160 | -------------------------------------------------------------------------------- /src/elementwise.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.ELEMENTWISE -*- 2 | ;;; Copyright (c) 2011-2014 Tamas Papp 3 | ;;; Copyright (c) 2023 Symbolics Pte Ltd 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | (uiop:define-package #:num-utils.elementwise 7 | (:use #:cl 8 | #:alexandria 9 | #:num-utils.arithmetic 10 | #:num-utils.utilities 11 | #:let-plus) 12 | (:nicknames #:elmt) ;num-util elementwise mathematics 13 | (:export 14 | #:elementwise-float-contagion 15 | #:e+ 16 | #:e- 17 | #:e* 18 | #:e/ 19 | #:e2+ 20 | #:e2- 21 | #:e2* 22 | #:e2/ 23 | #:e1- 24 | #:e1/ 25 | #:e2log 26 | #:e2exp 27 | #:e2mod 28 | #:e1log 29 | #:e1exp 30 | #:eexpt 31 | #:eexp 32 | #:elog 33 | #:emod 34 | #:esqrt 35 | #:efloor 36 | #:eceiling 37 | #:econjugate 38 | #:esquare 39 | #:ereduce 40 | #:emin 41 | #:emax 42 | #:esin 43 | #:ecos 44 | #:e2< 45 | #:e2<= 46 | #:e2> 47 | #:e2>= 48 | #:e2= 49 | #:eabs)) 50 | (in-package #:num-utils.elementwise) 51 | 52 | (defun elementwise-float-contagion (&rest objects) 53 | "Return the resulting float type when objects (or their elements) are combined using arithmetic operations." 54 | ;; TODO benchmark, optimize 55 | (let* ((matrix (load-time-value 56 | (let ((matrix (make-array `(10 10) 57 | :element-type '(integer 0 9)))) 58 | (dotimes (i1 10) 59 | (dotimes (i2 10) 60 | (let+ (((&values c1 f1) (floor i1 5)) 61 | ((&values c2 f2) (floor i2 5))) 62 | (setf (aref matrix i1 i2) 63 | (+ (max f1 f2) (* 5 (max c1 c2))))))) 64 | matrix)))) 65 | (declare (type (simple-array (integer 0 9) (10 10)) matrix)) 66 | (if objects 67 | (aref #(real 68 | short-float 69 | single-float 70 | double-float 71 | long-float 72 | complex 73 | (complex short-float) 74 | (complex single-float) 75 | (complex double-float) 76 | (complex long-float)) 77 | (reduce (lambda (i1 i2) (aref matrix i1 i2)) objects 78 | :key (lambda (object) 79 | (cond 80 | ((arrayp object) 81 | (let ((type (array-element-type object))) 82 | (cond 83 | ((subtypep type 'short-float) 1) 84 | ((subtypep type 'single-float) 2) 85 | ((subtypep type 'double-float) 3) 86 | ((subtypep type 'long-float) 4) 87 | ((subtypep type 'real) 0) 88 | ((subtypep type '(complex short-float)) 6) 89 | ((subtypep type '(complex single-float)) 7) 90 | ((subtypep type '(complex double-float)) 8) 91 | ((subtypep type '(complex long-float)) 9) 92 | ((subtypep type 'complex) 5) 93 | (t (return-from elementwise-float-contagion t))))) 94 | ((typep object 'short-float) 1) 95 | ((typep object 'single-float) 2) 96 | ((typep object 'double-float) 3) 97 | ((typep object 'long-float) 4) 98 | ((typep object 'real) 0) 99 | ((typep object '(complex short-float)) 6) 100 | ((typep object '(complex single-float)) 7) 101 | ((typep object '(complex double-float)) 8) 102 | ((typep object '(complex long-float)) 9) 103 | ((typep object 'complex) 5) 104 | (t (return-from elementwise-float-contagion t)))))) 105 | t))) 106 | 107 | ;;; various elementwise operations 108 | 109 | (defmacro mapping-array ((ref array &rest other) form) 110 | (check-type ref symbol) 111 | (with-unique-names (result index) 112 | (once-only (array) 113 | `(let ((,result (make-array (array-dimensions ,array) 114 | :element-type (elementwise-float-contagion 115 | ,array ,@other)))) 116 | (dotimes (,index (array-total-size ,result)) 117 | (setf (row-major-aref ,result ,index) 118 | (flet ((,ref (array) 119 | (row-major-aref array ,index))) 120 | ,form))) 121 | ,result)))) 122 | 123 | (defmacro define-e1 (operation 124 | &key (function (symbolicate '#:e1 operation)) 125 | (docstring (format nil "Univariate elementwise ~A." 126 | operation))) 127 | "Define an univariate elementwise operation." 128 | (check-types (function operation) symbol) 129 | `(defgeneric ,function (a) 130 | (declare (optimize speed)) 131 | (:documentation ,docstring) 132 | (:method ((a number)) 133 | (,operation a)) 134 | (:method ((a array)) 135 | (mapping-array (m a) (,operation (m a)))))) 136 | 137 | (define-e1 -) 138 | (define-e1 /) 139 | (define-e1 log) 140 | (define-e1 abs :function eabs) 141 | (define-e1 floor :function efloor) 142 | (define-e1 ceiling :function eceiling) 143 | (define-e1 exp :function eexp) 144 | (define-e1 sqrt :function esqrt) 145 | (define-e1 conjugate :function econjugate) 146 | (define-e1 square :function esquare) 147 | (define-e1 sin :function esin) 148 | (define-e1 cos :function ecos) 149 | 150 | 151 | (defmacro define-e2 (operation 152 | &key (function (symbolicate '#:e2 operation)) 153 | (docstring (format nil "Bivariate elementwise ~A." 154 | operation))) 155 | "Define a bivariate elementwise operation." 156 | (check-types (function operation) symbol) 157 | `(defgeneric ,function (a b) 158 | (declare (optimize speed)) 159 | (:documentation ,docstring) 160 | (:method ((a number) (b number)) 161 | (,operation a b)) 162 | 163 | ;; Vector class hierarchy. Includes specialised SBCL vectors. 164 | ;; TODO: See if neccessary. Added during debugging, but this was not the problem. 165 | (:method ((a vector) (b number)) 166 | (mapping-array (m a b) (,operation (m a) b))) 167 | (:method ((a number) (b vector)) 168 | (mapping-array (m b a) (,operation a (m b)))) 169 | (:method ((a vector) (b vector)) 170 | (assert (equal (array-dimensions a) (array-dimensions b))) 171 | (mapping-array (m a b) (,operation (m a) (m b)))) 172 | 173 | ;; Array class hierarchy 174 | (:method ((a array) (b number)) 175 | (mapping-array (m a b) (,operation (m a) b))) 176 | (:method ((a number) (b array)) 177 | (mapping-array (m b a) (,operation a (m b)))) 178 | (:method ((a array) (b array)) 179 | (assert (equal (array-dimensions a) (array-dimensions b))) 180 | (mapping-array (m a b) (,operation (m a) (m b)))))) 181 | 182 | 183 | (define-e2 +) 184 | (define-e2 -) 185 | (define-e2 *) 186 | (define-e2 /) 187 | (define-e2 expt :function eexpt) 188 | (define-e2 log) 189 | (define-e2 mod :function emod) 190 | (define-e2 <) 191 | (define-e2 <=) 192 | (define-e2 >) 193 | (define-e2 >=) 194 | (define-e2 =) 195 | 196 | 197 | (defun elog (a &optional (base nil base?)) 198 | "Elementwise logarithm." 199 | (if base? 200 | (e2log a base) 201 | (e1log a))) 202 | 203 | (defmacro define-e& (operation &key (function (symbolicate '#:e operation)) 204 | (bivariate (symbolicate '#:e2 operation)) 205 | (univariate (symbolicate '#:e1 operation)) 206 | (docstring (format nil "Elementwise ~A." 207 | operation))) 208 | `(defun ,function (argument &rest more-arguments) 209 | ,docstring 210 | (if more-arguments 211 | (reduce #',bivariate more-arguments :initial-value argument) 212 | (,univariate argument)))) 213 | 214 | (define-e& + :univariate identity) 215 | (define-e& -) 216 | (define-e& * :univariate identity) 217 | (define-e& /) 218 | 219 | (defgeneric ereduce (function object &key key) 220 | (:documentation "Elementwise reduce, traversing in row-major order.") 221 | (:method (function (array array) &key key) 222 | (reduce function (aops:flatten array) :key key)) 223 | (:method (function (sequence sequence) &key key) 224 | (reduce function sequence :key key)) 225 | (:method (function object &key key) 226 | (reduce function (aops:as-array object) :key key))) 227 | 228 | (defmacro define-elementwise-reduction 229 | (name function 230 | &optional (docstring (format nil "Elementwise ~A." function))) 231 | `(defun ,name (object) 232 | ,docstring 233 | (ereduce #',function object))) 234 | 235 | (define-elementwise-reduction emax max) 236 | (define-elementwise-reduction emin min) 237 | -------------------------------------------------------------------------------- /src/extended-real.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.EXTENDED-REAL -*- 2 | ;;; Copyright (c) 2011-2014 Tamas Papp 3 | ;;; Copyright (c) 2023 Symbolics Pte Ltd 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | (uiop:define-package #:num-utils.extended-real 7 | (:use #:cl #:alexandria) 8 | (:nicknames #:xreal) 9 | (:shadow #:= #:< #:> #:<= #:>=) 10 | (:export 11 | :infinite? 12 | :extended-real 13 | := 14 | :< 15 | :> 16 | :<= 17 | :>= 18 | :plusinf 19 | :minusinf 20 | :with-template 21 | :lambda-template)) 22 | (in-package #:num-utils.extended-real) 23 | 24 | 25 | (deftype infinite () 26 | "Representing infinity (extending the real line)." 27 | '(member :plusinf :minusinf)) 28 | 29 | (defun infinite? (object) 30 | "Test if an object represents positive or negative infinity." 31 | (typep object 'infinite)) 32 | 33 | (deftype extended-real (&optional (base 'real)) 34 | "Extended real number." 35 | `(or infinite ,base)) 36 | 37 | (defun extend-pairwise-comparison (test first rest) 38 | "Extend TEST (a pairwise comparison) to an arbitrary number of arguments (but at least one, FIRST)." 39 | (loop while rest do 40 | (let ((next (car rest))) 41 | (unless (funcall test first next) 42 | (return-from extend-pairwise-comparison nil)) 43 | (setf first next 44 | rest (cdr rest)))) 45 | t) 46 | 47 | (defmacro with-template ((prefix &rest variables) &body body) 48 | "Define the function (PREFIX &rest VARIABLES) which can be used to match variables using :PLUSINF, :MINUSINF, REAL, or T." 49 | (let ((names (mapcar (curry #'symbolicate 'kind-) variables))) 50 | `(macrolet ((,prefix ,names 51 | (flet ((expand (kind variable) 52 | (ecase kind 53 | (:plusinf `(eq :plusinf ,variable)) 54 | (:minusinf `(eq :minusinf ,variable)) 55 | (real `(realp ,variable)) 56 | ((t) t)))) 57 | (list 'and 58 | ,@(mapcar (lambda (name variable) 59 | `(expand ,name ',variable)) 60 | names variables))))) 61 | ,@(loop for v in variables 62 | collect `(check-type ,v extended-real)) 63 | ,@body))) 64 | 65 | (defmacro lambda-template ((prefix &rest variables) &body body) 66 | "LAMBDA with WITH-TEMPLATE in its BODY." 67 | `(lambda ,variables 68 | (with-template (,prefix ,@variables) 69 | ,@body))) 70 | 71 | (defmacro define-comparison (name test) 72 | "Define a comparison, extendeding a pairwise comparison to an arbitrary number of arguments." 73 | `(defun ,name (number &rest more-numbers) 74 | (extend-pairwise-comparison ,test number more-numbers))) 75 | 76 | (define-comparison = 77 | (lambda-template (? a b) 78 | (if (? real real) 79 | (cl:= a b) 80 | (or (? :plusinf :plusinf) 81 | (? :minusinf :minusinf))))) 82 | 83 | (define-comparison < 84 | (lambda-template (? a b) 85 | (if (? real real) 86 | (cl:< a b) 87 | (or (? :minusinf :plusinf) 88 | (? :minusinf real) 89 | (? real :plusinf))))) 90 | 91 | (define-comparison > 92 | (lambda-template (? a b) 93 | (if (? real real) 94 | (cl:> a b) 95 | (or (? :plusinf :minusinf) 96 | (? real :minusinf) 97 | (? :plusinf real))))) 98 | 99 | (define-comparison <= 100 | (lambda-template (? a b) 101 | (if (? real real) 102 | (cl:<= a b) 103 | (or (? :minusinf t) 104 | (? t :plusinf))))) 105 | 106 | (define-comparison >= 107 | (lambda-template (? a b) 108 | (if (? real real) 109 | (cl:>= a b) 110 | (or (? t :minusinf) 111 | (? :plusinf t))))) 112 | 113 | ;;; TODO /=, min, max, minusp, plusp, abs, ... 114 | -------------------------------------------------------------------------------- /src/log-exp.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.LOG-EXP -*- 2 | ;;; Copyright (c) 2021, 2023 by Symbolics Pte. Ltd. All rights reserved. 3 | ;;; SPDX-License-identifier: MS-PL 4 | 5 | (uiop:define-package #:num-utils.log-exp 6 | (:use #:cl #:let-plus) 7 | (:import-from #:num-utils.arithmetic 8 | #:ln 9 | #:square) 10 | (:import-from #:num-utils.polynomial 11 | #:evaluate-polynomial) 12 | (:import-from #:num-utils.utilities 13 | #:simple-double-float-vector) 14 | (:export #:log1+ 15 | #:log1- 16 | #:log1+/x 17 | #:exp-1 18 | #:exp-1/x 19 | #:expt-1 20 | #:log1-exp 21 | #:log1+exp 22 | #:log2-exp 23 | #:logexp-1 24 | #:hypot 25 | #:log1pmx)) 26 | (in-package #:num-utils.log-exp) 27 | 28 | ;;; Functions based on log and exp that require special handling near 29 | ;;; zero 30 | 31 | ;;; for log1+ and exp-1, 32 | ;;; both ultimately from a document of Kahan's somewhere on his web 33 | ;;; page: http://people.eecs.berkeley.edu/~wkahan/ 34 | 35 | (declaim (inline log1+ log1-)) 36 | 37 | (defun log1+ (x) 38 | "Compute (log (1+ x)) stably even when X is near 0." 39 | (let ((u (+ 1 x))) 40 | (if (= u 1) 41 | x 42 | (/ (* x (ln u)) 43 | (- u 1))))) 44 | 45 | (defun log1- (x) 46 | "Compute (log (- 1 x)) stably even when X is near zero." 47 | (log1+ (- x))) 48 | 49 | (defun log1+/x (x) 50 | "Compute (/ (log (+ 1 x)) x) stably even when X is near zero." 51 | (let ((u (+ x 1))) 52 | (if (= u 1) 53 | x 54 | (/ (log u) 55 | (- u 1))))) 56 | 57 | (defun exp-1 (x) 58 | "Compute (- (exp x) 1) stably even when X is near 0" 59 | (let ((u (exp x))) 60 | (if (= u 1) 61 | x 62 | (let ((v (- u 1))) 63 | (if (= v -1) 64 | -1 65 | (/ (* v x) 66 | (ln u))))))) 67 | 68 | (defun exp-1/x (x) 69 | "Compute (/ (- (exp x) 1) x) stably even when X is near zero." 70 | (let ((u (exp x))) 71 | (if (= u 1) 72 | x 73 | (let ((v (- u 1))) 74 | (if (= v -1) 75 | (/ -1 x) 76 | (/ v (log u))))))) 77 | 78 | (defun expt-1 (a z) 79 | "Compute (a^z)-1 stably even when A is close to 1 or Z is close to 80 | zero." 81 | (or (and (or (< (abs a) 1) 82 | (< (abs z) 1)) 83 | (let ((p (* (log a) z))) 84 | (and (< (abs p) 2) 85 | (exp-1 p)))) 86 | (- (expt a z) 1))) 87 | 88 | (defun log1-exp (a) 89 | "Compute log(1-exp(x)) stably even when A is near zero. 90 | This is sometimes known as the E_3, the third Einstein function. 91 | See Mächler 2008 for notes on accurate calculation. 92 | https://cran.r-project.org/web/packages/Rmpfr/vignettes/log1mexp-note.pdf" 93 | (cond ((or (complexp a) (minusp a)) 94 | ;; XXX 95 | (log (- 1 (exp a)))) 96 | ((<= a 0) ;XXX 97 | #+ () (log1- (- (exp (- a)))) 98 | (log1+ (- (exp a))) 99 | #+ () (log (- 1 (exp a)))) 100 | ((<= a #.(log 2d0)) 101 | (log (- (exp-1 a)))) 102 | (t 103 | ;; The paper has -a, but that's wrong. 104 | (log1+ (- (exp a)))))) 105 | 106 | (defun log1+exp (a) 107 | "Accurately compute log(1+exp(x)) even when A is near zero." 108 | (if (realp a) 109 | (let ((x (coerce a 'double-float))) 110 | (cond ((<= x -37) 111 | (exp x)) 112 | ((<= x 18) 113 | (log1+ (exp x))) 114 | ((<= x 33.3) 115 | (+ x (exp (- x)))) 116 | (t x))) 117 | (log (+ 1 (exp a))))) 118 | 119 | (defun log2-exp (x) 120 | "Compute log(2-exp(x)) stably even when X is near zero." 121 | (log1+ (- (exp-1 x)))) 122 | 123 | (defun logexp-1 (a) 124 | "Compute log(exp(a)-1) stably even when A is small." 125 | (if (realp a) 126 | (let ((x (coerce a 'double-float))) 127 | (cond ((<= x -37) 128 | 0d0) 129 | ((<= x 18) 130 | (log (exp-1 x))) 131 | ((<= x 33.3) 132 | (- x (exp (- x)))) 133 | (t x))) 134 | (log (- (exp a) 1)))) 135 | 136 | (defun hypot (x y) ;; TODO: move elsewhere? 137 | "Compute the hypotenuse of X and Y without danger of floating-point 138 | overflow or underflow." 139 | (setf x (abs x) 140 | y (abs y)) 141 | (when (< x y) 142 | (rotatef x y)) 143 | (* x (sqrt (+ 1 (square (/ y x)))))) 144 | 145 | ;; Julia, the source of this, has only three basic tests (NaN, +/- 146 | ;; infinity). My spot-testing against the R implementation shows exact 147 | ;; match to 16 decimals. 148 | (defun log1pmx (x) 149 | "Compute (- (log (1+ x)) x) 150 | Accuracy within ~2ulps for -0.227 < x < 0.315" 151 | (declare (double-float x)) 152 | (let+ (((&flet kernel (x) 153 | (let* ((r (/ x (+ 2 x))) 154 | (s (square r)) 155 | (w (evaluate-polynomial (coerce #(1.17647058823529412d-1 ;2/17 156 | 1.33333333333333333d-1 ;2/15 157 | 1.53846153846153846d-1 ;2/13 158 | 1.81818181818181818d-1 ;2/11 159 | 2.22222222222222222d-1 ;2/9 160 | 2.85714285714285714d-1 ;2/7 161 | 4d-1 ;2/5 162 | 6.66666666666666667d-1);2/3 163 | 'simple-double-float-vector) 164 | s)) 165 | (hxsq (* 0.5d0 x x))) 166 | (- (* r (+ hxsq (* w s))) hxsq))))) 167 | (cond 168 | ((not (< -0.7 x 0.9)) (- (log1+ x) x)) 169 | ((> x 0.315) (let ((u (/ (- x 0.5) 1.5))) 170 | (- (kernel u) 9.45348918918356180d-2 (* 0.5 u)))) 171 | ((> x -0.227) (kernel x)) 172 | ((> x -0.4) (let ((u (/ (+ x 0.25) 0.75))) 173 | (+ (kernel u) -3.76820724517809274d-2 (* 0.25 u)))) 174 | ((> x -0.6) (let ((u (* (+ x 0.5) 2))) 175 | (+ (kernel u) -1.93147180559945309d-1 (* 0.5 u)))) 176 | (t (let ((u (/ (+ x 0.625) 0.375))) 177 | (+ (kernel u) -3.55829253011726237d-1 (* 0.625 u))))))) 178 | 179 | #| 180 | References: 181 | https://github.com/ruricolist/floating-point-contractions/blob/master/floating-point-contractions.lisp 182 | Test data: 183 | https://code.woboq.org/boost/boost/libs/math/test/log1p_expm1_data.ipp.html 184 | |# 185 | -------------------------------------------------------------------------------- /src/matrix-shorthand.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.MATRIX-SHORTHAND -*- 2 | ;;; Copyright (c) 2011-2014 Tamas Papp 3 | ;;; Copyright (c) 2023 Symbolics Pte Ltd 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | (uiop:define-package #:num-utils.matrix-shorthand 7 | (:nicknames #:nu.mx) 8 | (:use #:cl 9 | #:alexandria 10 | #:anaphora 11 | #:num-utils.matrix 12 | #:num-utils.utilities 13 | #:let-plus) 14 | (:export 15 | #:vec 16 | #:mx 17 | #:diagonal-mx 18 | #:lower-triangular-mx 19 | #:hermitian-mx 20 | #:upper-triangular-mx)) 21 | (in-package #:num-utils.matrix-shorthand) 22 | 23 | 24 | (defun vec (element-type &rest elements) 25 | "Return a vector with elements coerced to ELEMENT-TYPE." 26 | (map `(simple-array ,element-type (*)) 27 | (lambda (element) (coerce element element-type)) 28 | elements)) 29 | 30 | (defun diagonal-mx (element-type &rest elements) 31 | "Return a DIAGONAL-MATRIX with elements coerced to ELEMENT-TYPE." 32 | (diagonal-matrix (apply #'vec element-type elements))) 33 | 34 | (defmacro mx (element-type &body rows) 35 | "Macro for creating a dense matrix (ie a rank 2 array). ROWS should be a list of lists (or atoms, which are treated as lists), elements are evaluated." 36 | (let+ ((rows (map 'vector #'ensure-list rows)) 37 | (nrow (length rows)) 38 | (ncol (length (aref rows 0))) 39 | ((&once-only element-type))) 40 | `(make-array (list ,nrow ,ncol) 41 | :element-type ,element-type 42 | :initial-contents 43 | (list 44 | ,@(loop for row across rows collect 45 | `(list 46 | ,@(loop for element in row collect 47 | `(coerce ,element ,element-type)))))))) 48 | 49 | (defun pad-left-expansion (rows ncol) 50 | "Pad ragged-right rows. Used internally to implement ragged right matrix specifications." 51 | (loop for row in rows 52 | for row-index from 0 53 | collect (aprog1 (make-sequence 'list ncol :initial-element 0) 54 | (replace it row :start1 0 :end1 (min ncol (1+ row-index)))))) 55 | 56 | (defmacro lower-triangular-mx (element-type &body rows) 57 | "Create a lower triangular matrix. ROWS should be a list of lists, elements are evaluated. Masked elements (above the diagonal) are ignored at the expansion, rows which don't have enough elements are padded with zeros." 58 | `(lower-triangular-matrix 59 | (mx ,element-type 60 | ,@(pad-left-expansion (mapcar #'ensure-list rows) 61 | (reduce #'max rows :key #'length))))) 62 | 63 | (defmacro hermitian-mx (element-type &body rows) 64 | "Create a lower triangular matrix. ROWS should be a list of lists, elements are evaluated. Masked elements (above the diagonal) are ignored at the expansion, rows which don't have enough elements are padded with zeros." 65 | `(hermitian-matrix 66 | (mx ,element-type 67 | ,@(pad-left-expansion (mapcar #'ensure-list rows) 68 | (max (length rows) 69 | (reduce #'max rows :key #'length)))))) 70 | 71 | (defmacro upper-triangular-mx (element-type &body rows) 72 | "Create an upper triangular matrix. ROWS should be a list of lists, elements are evaluated. Masked elements (below the diagonal) are ignored at the expansion." 73 | `(upper-triangular-matrix 74 | (mx ,element-type 75 | ,@(loop for row-index from 0 76 | for row in rows 77 | collect (loop for column-index from 0 78 | for element in (ensure-list row) 79 | collect (if (< column-index row-index) 80 | 0 81 | element)))))) 82 | -------------------------------------------------------------------------------- /src/num=.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.NUM= -*- 2 | ;;; Copyright (c) 2011-2014 Tamas Papp 3 | ;;; Copyright (c) 2023 Symbolics Pte Ltd 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | (uiop:define-package #:num-utils.num= 7 | (:use #:cl 8 | #:alexandria 9 | #:anaphora 10 | #:let-plus) 11 | (:export #:num-delta 12 | #:*num=-tolerance* 13 | #:num= 14 | #:num=-function 15 | #:define-num=-with-accessors 16 | #:define-structure-num=)) 17 | (in-package #:num-utils.num=) 18 | 19 | 20 | (defparameter *num=-tolerance* 1d-5 "Default tolerance for NUM=.") 21 | 22 | (defun num-delta (a b) 23 | "|a-b|/max(1,|a|,|b|). Useful for comparing numbers." 24 | (/ (abs (- a b)) 25 | (max 1 (abs a) (abs b)))) 26 | 27 | (defgeneric num= (a b &optional tolerance) 28 | (:documentation "Compare A and B for approximate equality, checking corresponding elements when applicable (using TOLERANCE). 29 | 30 | Two numbers A and B are NUM= iff |a-b|/max(1,|a|,|b|) <= tolerance. 31 | 32 | Unless a method is defined for them, two objects are compared with EQUALP. 33 | 34 | Generally, methods should be defined so that two objects are NUM= if they the same class, same dimensions, and all their elements are NUM=.") 35 | (:method (a b &optional (tolerance *num=-tolerance*)) 36 | (declare (ignore tolerance)) 37 | (equalp a b)) 38 | (:method ((a number) (b number) &optional (tolerance *num=-tolerance*)) 39 | (<= (abs (- a b)) (* (max 1 (abs a) (abs b)) tolerance))) 40 | (:method ((a array) (b array) &optional (tolerance *num=-tolerance*)) 41 | (and (equal (array-dimensions a) (array-dimensions b)) 42 | (loop 43 | for index :below (array-total-size a) 44 | always (num= (row-major-aref a index) 45 | (row-major-aref b index) 46 | tolerance)))) 47 | (:method ((a cons) (b cons) &optional (tolerance *num=-tolerance*)) 48 | (and (num= (car a) (car b) tolerance) 49 | (num= (cdr a) (cdr b) tolerance))) 50 | (:method ((a null) (b null) &optional (tolerance *num=-tolerance*)) 51 | (declare (ignore tolerance)) 52 | t)) 53 | 54 | (defun num=-function (tolerance) 55 | "Curried version of num=, with given tolerance." 56 | (lambda (a b) 57 | (num= a b tolerance))) 58 | 59 | (defmacro define-num=-with-accessors (class accessors) 60 | "Define a method for NUM=, specialized to the given class, comparing values obtained with accessors." 61 | `(defmethod num= ((a ,class) (b ,class) 62 | &optional (tolerance *num=-tolerance*)) 63 | (and ,@(loop for accessor in accessors 64 | collect `(num= (,accessor a) (,accessor b) tolerance))))) 65 | 66 | (defmacro define-structure-num= (structure &rest slots) 67 | "Define a NUM= method for the given structure, comparing the given slots." 68 | (check-type structure symbol) 69 | `(define-num=-with-accessors ,structure 70 | ,(loop for slot in slots 71 | collect (symbolicate structure "-" slot)))) 72 | -------------------------------------------------------------------------------- /src/old/arithmetic-type.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils) 4 | 5 | (defun all-float-types () 6 | "Return a list of float types." 7 | '(short-float single-float double-float long-float)) 8 | 9 | (defun available-float-type? (type) 10 | "Return T iff type is available as a specialized array element type." 11 | (equal type (upgraded-array-element-type type))) 12 | 13 | (defun array-float-types () 14 | "Return a list of float types which are upgraded to themselves. 15 | Consequences are undefined if modified." 16 | (load-time-value 17 | (remove-if (complement #'available-float-type?) (all-float-types)))) 18 | 19 | (defun array-float-and-complex-types () 20 | "Return a list of float types which are upgraded to themselves. 21 | Consequences are undefined if modified." 22 | (load-time-value 23 | (remove-if (complement #'available-float-type?) 24 | (append (all-float-types) 25 | (mapcar (lambda (type) `(complex ,type)) 26 | (all-float-types)))) 27 | t)) 28 | 29 | 30 | 31 | (defun recognized-float-types () 32 | (let ((float '(short-float single-float double-float long-float))) 33 | (concatenate 'vector float 34 | (mapcar (curry #'list 'complex) float)))) 35 | 36 | (macrolet ((define% () 37 | `(defun float-type-index (type) 38 | (cond 39 | ,@(let ((index 0)) 40 | (map 'list (lambda (type) 41 | (prog1 `((subtypep type ',type) ,index) 42 | (incf index))) 43 | (recognized-float-types))) 44 | (t nil))))) 45 | (define%)) 46 | 47 | (defun float-contagion-matrix () 48 | (let ((indexes (ivec (length (recognized-float-types))))) 49 | (outer* indexes indexes 50 | (lambda (i1 i2) 51 | )))) 52 | 53 | (defun float-contagion (&rest types) 54 | (declare (optimize speed)) 55 | (let ((matrix (load-time-value 56 | (let ((matrix (make-array '(8 8) 57 | :element-type '(integer 0 7)))) 58 | (dotimes (i1 8) 59 | (dotimes (i2 8) 60 | (multiple-value-bind (c1 f1) (floor i1 4) 61 | (multiple-value-bind (c2 f2) (floor i2 4) 62 | (setf (aref matrix i1 i2) 63 | (+ (max f1 f2) (* 4 (max c1 c2)))))))) 64 | matrix)))) 65 | (declare (type (simple-array (integer 0 7) (8 8)) matrix)) 66 | (if types 67 | (aref #(short-float 68 | single-float 69 | double-float 70 | long-float 71 | (complex short-float) 72 | (complex single-float) 73 | (complex double-float) 74 | (complex long-float)) 75 | (reduce (lambda (i1 i2) (aref matrix i1 i2)) types 76 | :key (lambda (type) 77 | (cond 78 | ((subtypep type 'short-float) 0) 79 | ((subtypep type 'single-float) 1) 80 | ((subtypep type 'double-float) 2) 81 | ((subtypep type 'long-float) 3) 82 | ((subtypep type '(complex short-float)) 4) 83 | ((subtypep type '(complex single-float)) 5) 84 | ((subtypep type '(complex double-float)) 6) 85 | ((subtypep type '(complex long-float)) 7) 86 | (t (return-from float-contagion t)))))) 87 | nil))) 88 | 89 | 90 | 91 | (defmacro define-float-contagion () 92 | ) 93 | 94 | (defun float-contagion (type1 type2) 95 | (let+ (() 96 | ((&labels classify (type) 97 | (cond 98 | ((subtypep type 'complex) (values (classify ()))) 99 | ) 100 | (typecase type 101 | (complex ) 102 | (float )) 103 | ) 104 | ))) 105 | ) 106 | 107 | (defmacro define-arithmetic-contagion (function float-types 108 | &optional (docstring "")) 109 | "Define (FUNCTION TYPES) which returns the result type applying float and 110 | complex contagion rules to TYPES, considering FLOAT-TYPES and their complex 111 | counterparts. For types outside these, T is returned." 112 | (let+ (((&flet map-types (function) 113 | (loop for type in float-types 114 | for index from 0 115 | collect (funcall function type index)))) 116 | ((¯olet amap-types (form) 117 | `(map-types (lambda (type index) ,form))))) 118 | `(defun ,function (types) 119 | ,docstring 120 | (declare (optimize speed)) 121 | (let ((complex? nil) 122 | (float 0)) 123 | (declare (type fixnum float)) 124 | (loop for type in types do 125 | (let+ (((&values f c?) 126 | (cond 127 | ,@(amap-types `((subtypep type '(complex ,type)) 128 | (values ,index t))) 129 | ,@(amap-types `((subtypep type ',type) ,index)) 130 | (t (return-from ,function t))))) 131 | (maxf float f) 132 | (setf complex? (or complex? c?)))) 133 | (if complex? 134 | (case float ,@(amap-types `(,index '(complex ,type)))) 135 | (case float ,@(amap-types `(,index ',type)))))))) 136 | 137 | (define-arithmetic-contagion array-arithmetic-contagion 138 | #.(array-float-types) 139 | "Return the upgraded element type of the arguments, applying rules of 140 | float and complex contagion.") 141 | 142 | (array-arithmetic-contagion '(double-float (complex single-float))) 143 | 144 | -------------------------------------------------------------------------------- /src/old/bins.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils) 4 | 5 | ;;; bins -- generic interface 6 | ;;; 7 | ;;; BINS are univariate mappings to FIXNUMs, either based on exact 8 | ;;; correspondence (discrete bins) or location on the real line (continuous 9 | ;;; bins). They are the (univariate) building blocks for histograms, used as 10 | ;;; cross products when necessary. 11 | 12 | (defgeneric bin-index (bins value) 13 | (:documentation 14 | "Return the index (a FIXNUM) that corresponds to VALUE in BIN.")) 15 | 16 | (defgeneric bin-location (bins index) 17 | (:documentation 18 | "Return the value or interval that corresponds to the bin with INDEX.")) 19 | 20 | ;;; evenly distributed bins 21 | 22 | (defstruct (even-bins (:constructor even-bins (width &optional (offset 0)))) 23 | "Evenly distributed bins. Especially fast as binning requires simple 24 | arithmetic." 25 | (offset nil :type real :read-only t) 26 | (width nil :type real :read-only t)) 27 | 28 | (defmethod bin-index ((even-bins even-bins) value) 29 | (values (floor (- value (even-bins-offset even-bins)) 30 | (even-bins-width even-bins)))) 31 | 32 | (defmethod bin-location ((even-bins even-bins) index) 33 | (let+ (((&structure even-bins- offset width) even-bins) 34 | (left (+ (* index width) offset))) 35 | (interval left (+ left width)))) 36 | 37 | (defun pretty-bins (width n &key (min-step (default-min-step width)) 38 | (bias *pretty-bias*) (five-bias *pretty-five-bias*)) 39 | "Bins with a pretty step size, calculated using PRETTY-STEP (see its 40 | documentation)." 41 | (even-bins (pretty-step width n :min-step min-step :bias bias 42 | :five-bias five-bias))) 43 | 44 | ;;; integer bins 45 | 46 | (defstruct (integer-bins (:constructor integer-bins)) 47 | "Integer bins, for exact categorization. All integers (fixnums) are mapped 48 | to themselves, other values raise an error.") 49 | 50 | (defmethod bin-index ((integer-bins integer-bins) value) 51 | (check-type value fixnum) 52 | value) 53 | 54 | (defmethod bin-location ((integer-bins integer-bins) index) 55 | index) 56 | 57 | ;; ;;; irregular bins 58 | 59 | ;; (declaim (inline within-breaks? in-bin?% find-bin%)) 60 | 61 | ;; (defun in-bin?% (value index breaks) 62 | ;; "Return non-nil iff VALUE is in the bin corresponding to INDEX. No 63 | ;; error checking, for internal use." 64 | ;; (within? (aref breaks index) 65 | ;; value 66 | ;; (aref breaks (1+ index)))) 67 | 68 | ;; (defun find-bin% (value breaks right &aux (left 0)) 69 | ;; "Find the bin index for value. BREAKS should be strictly 70 | ;; increasing. The invariants 0 <= LEFT < RIGHT < (LENGTH BREAKS) 71 | ;; and (WITHIN-BREAKS? VALUE (AREF BREAKS LEFT) (AREF BREAKS RIGHT)) 72 | ;; are maintaned and expected to be satisfied when calling this function. For 73 | ;; internal use." 74 | ;; (loop 75 | ;; (when (= (1+ left) right) 76 | ;; (return left)) 77 | ;; (let ((middle (floor (+ left right) 2))) 78 | ;; (if (< value (aref breaks middle)) 79 | ;; (setf right middle) 80 | ;; (setf left middle))))) 81 | 82 | ;; (defun irregular-bins (breaks &key copy? skip-check? 83 | ;; (below nil below-p) (above nil above-p)) 84 | ;; "Return a binning function for irregular bins with BREAKS (right continuous). 85 | ;; If copy?, BREAKS will be copied, otherwise it may share structure. BREAKS 86 | ;; should be strictly increasing, this is checked unless SKIP-CHECK?. When BELOW 87 | ;; and/or ABOVE are given, value below the first or after the last bin are binned 88 | ;; accordingly, otherwise an error is signalled." 89 | ;; (let* ((breaks (if copy? 90 | ;; (if (vectorp breaks) 91 | ;; (copy-seq breaks) 92 | ;; (coerce breaks 'vector)) 93 | ;; breaks)) 94 | ;; (right (1- (length breaks))) 95 | ;; (left-boundary (aref breaks 0)) 96 | ;; (right-boundary (aref breaks right))) 97 | ;; (unless skip-check? 98 | ;; (assert (vector-satisfies? breaks #'<))) 99 | ;; (lambda (value) 100 | ;; (cond 101 | ;; ((< value left-boundary) 102 | ;; (if below-p 103 | ;; below 104 | ;; (error "~A is below ~A, the first break." 105 | ;; value left-boundary))) 106 | ;; ((<= right-boundary value) 107 | ;; (if above-p 108 | ;; above 109 | ;; (error "~A is above ~A, the last break." 110 | ;; value right-boundary))) 111 | ;; (t (find-bin% value breaks right)))))) 112 | 113 | ;;; utility functions 114 | 115 | (defun format-bin-location (location) 116 | "Return location, formatted as a string." 117 | (let+ (((&interval left right) location)) 118 | (etypecase location 119 | (interval (format nil "[~A,~A]" 120 | (format-number left) 121 | (format-number right))) 122 | (real (format-number location))))) 123 | 124 | (defun binary-search (sorted i) 125 | "Binary search for a number I on a sequence (vector preferred) sorted in 126 | strictly increasing order (not checked) returning the index. When I is not 127 | found, return NIL." 128 | (let* ((sorted (coerce sorted 'vector)) 129 | (left 0) 130 | (right (1- (length sorted)))) 131 | (assert (<= 0 right) () "Vector has no elements.") 132 | (unless (<= (aref sorted left) i (aref sorted right)) 133 | (return-from binary-search nil)) 134 | (do () ((> left right) nil) 135 | (let* ((middle (floor (+ left right) 2)) 136 | (middle-value (aref sorted middle))) 137 | (cond 138 | ((= middle-value i) 139 | (return-from binary-search middle)) 140 | ((< middle-value i) 141 | (setf left (1+ middle))) 142 | (t 143 | (setf right (1- middle)))))))) 144 | -------------------------------------------------------------------------------- /src/old/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils) 4 | 5 | (define-condition reached-maximum-iterations () 6 | ((n :initarg :n :documentation "Number of iterations."))) 7 | 8 | (define-condition internal-error () 9 | () 10 | (:report "Internal error. Please report it as a bug.") 11 | (:documentation "An error that is not supposed to happen if the code is correct. May be the result of numerical imprecision. Please report it as a bug.")) 12 | 13 | (define-condition not-implemented () 14 | () 15 | (:report "This functionality is not implemented yet. If you need it, please report it as an issue.") 16 | (:documentation "Placeholder condition for functionality that is not implemented yet.")) 17 | -------------------------------------------------------------------------------- /src/old/differentiation.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils) 4 | 5 | (defgeneric differentiate% (n method f x h) 6 | (:documentation "Calculate the Nth derivative of F at X, using a (relative) 7 | stepsize H and the given METHOD. When H is nil, a sensible default is chosen. 8 | If there is a second value returned, it is F(X) (useful for calculating 9 | elasticities).")) 10 | 11 | (defun differentiate (f x &key (n 1) (method :right) h) 12 | (differentiate% n method f x h)) 13 | 14 | (defun numdiff-epsilon (x &optional h) 15 | "Sensible choice of epsilon for numerical differentiation." 16 | (* (max (abs x) 1) 17 | (if h 18 | h 19 | (sqrt double-float-epsilon)))) 20 | 21 | (defmethod differentiate% ((n (eql 1)) (method (eql :right)) f (x real) h) 22 | (let* ((x (float x 1d0)) 23 | (h (numdiff-epsilon x h)) 24 | (fx (funcall f x))) 25 | (values (/ (- (funcall f (+ x h)) fx) 26 | h) 27 | fx))) 28 | 29 | (defun add-standard-basis-vector (x axis h) 30 | "Return a x+e, where e_i = h if i=axis, 0 otherwise." 31 | (aprog1 (copy-array x) 32 | (incf (aref it axis) h))) 33 | 34 | (defmethod differentiate% ((n (eql 1)) (method (eql :right)) f (x vector) h) 35 | (let ((fx (funcall f x)) 36 | (h (map 'vector (lambda (x) (numdiff-epsilon x h)) x)) 37 | (length (length x))) 38 | (aprog1 (make-array length) 39 | (loop for axis below length 40 | for h across h 41 | do (setf (aref it axis) 42 | (/ (- (funcall f (add-standard-basis-vector x axis h)) fx) 43 | h)))))) 44 | 45 | ;;; !!! todo: write two-sided, left, Richardson approximation, etc 46 | 47 | (defun derivative (f &key (n 1) (method :right) h) 48 | "Return a function that calculates the derivative numerically. See 49 | DIFFERENTIATE for an explanation of the parameters." 50 | (lambda (x) 51 | (differentiate f x :n n :method method :h h))) 52 | 53 | (defun semi-elasticity (f &key (n 1) (method :right) h) 54 | "Return a function that calculates the semi-elasticity numerically. See 55 | DIFFERENTIATE for an explanation of the parameters." 56 | (lambda (x) 57 | (let+ (((&values df fx) 58 | (differentiate f x :n n :method method :h h))) 59 | (/ df fx)))) 60 | 61 | (defun elasticity (f &key (n 1) (method :right) h) 62 | "Return a function that calculates the elasticity numerically. See 63 | DIFFERENTIATE for an explanation of the parameters." 64 | (lambda (x) 65 | (let+ (((&values df fx) 66 | (differentiate f x :n n :method method :h h))) 67 | (* df (/ x fx))))) 68 | -------------------------------------------------------------------------------- /src/old/interaction.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils) 4 | 5 | (defun interaction (&rest binned-datas) 6 | "Interaction of binned data series. Return discrete-binned-data, where the 7 | bins refer to subscripts in row-major ordering (see keys)." 8 | (declare (optimize debug)) 9 | (let* ((dimensions (mapcar #'bin-limit binned-datas)) 10 | (bins (mapcar #'indexes binned-datas)) 11 | (length (length (first bins))) 12 | (which (make-array dimensions :element-type 'bit :initial-element 0)) 13 | (table (make-hash-table :test #'eql))) 14 | (assert (every (lambda (b) (= length (length b))) (cdr bins)) 15 | () "Indexes don't have the same length.") 16 | (let* (;; flag and save row-major positions 17 | (row-major-positions 18 | (iterate 19 | (for index :below length) 20 | (let ((position 21 | (apply #'array-row-major-index which 22 | (mapcar (lambda (b) (aref b index)) bins)))) 23 | (setf (row-major-aref which position) 1) 24 | (collect position)))) 25 | ;; keep row-major indexes which have elements, save corresponding 26 | ;; subscripts 27 | row-major-indexes subscripts) 28 | (with-indexing* (dimensions index index-next 29 | :counters counters) 30 | (iter 31 | (unless (zerop (row-major-aref which index)) 32 | (push index row-major-indexes) 33 | (push (copy-seq counters) subscripts)) 34 | (until (index-next))) 35 | (setf row-major-indexes (coerce (nreverse row-major-indexes) 36 | 'simple-fixnum-vector) 37 | subscripts (coerce (nreverse subscripts) 'vector))) 38 | ;; create hash-table for reverse mapping 39 | (iter 40 | (for row-major-index :in-vector row-major-indexes :with-index flat-index) 41 | (setf (gethash row-major-index table) flat-index)) 42 | ;; reverse mapping 43 | (make-instance 'discrete-binned-data 44 | :indexes (map 'simple-fixnum-vector 45 | (lambda (row-major-position) 46 | (gethash row-major-position table)) 47 | row-major-positions) 48 | :keys subscripts)))) 49 | -------------------------------------------------------------------------------- /src/old/misc.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils) 4 | 5 | (defun nonnegative? (x) 6 | "Returns T if x >= 0, otherwise NIL." 7 | (<= 0 x)) 8 | 9 | (defun nonpositive? (x) 10 | "Returns T if x <= 0, otherwise NIL." 11 | (>= 0 x)) 12 | 13 | (defmacro nif (value positive negative &optional zero) 14 | "Numeric if." 15 | (once-only (value) 16 | `(cond 17 | ((plusp ,value) ,positive) 18 | ((minusp ,value) ,negative) 19 | ,@(when zero 20 | `((t ,zero)))))) 21 | 22 | (defmacro anif (value positive negative &optional zero) 23 | "Anaphoric numeric if." 24 | `(let ((it ,value)) 25 | (cond 26 | ((plusp it) ,positive) 27 | ((minusp it) ,negative) 28 | ,@(when zero 29 | `((t ,zero)))))) 30 | 31 | (define-modify-macro multf (&rest values) * "Multiply by the arguments") 32 | 33 | 34 | (defun common-supertype (type-1 type-2) 35 | "Return a common supertype of the two types. Might not be the narrowest - it 36 | defaults to T if neither type is a subtype of the other. Intended use is 37 | finding a common array element type." 38 | (cond 39 | ((subtypep type-1 type-2) type-2) 40 | ((subtypep type-2 type-1) type-1) 41 | (t t))) 42 | 43 | (defun round* (number digits) 44 | "Round NUMBER to the given number of decimal digits." 45 | (let* ((pow10 (expt 10 (- digits))) 46 | (rounded-number (* (round number pow10) pow10))) 47 | (if (and (floatp number) (plusp digits)) 48 | (float rounded-number number) 49 | rounded-number))) 50 | 51 | (defun maybe-copy-array (array copy?) 52 | "If COPY?, return a shallow copy of array, otherwise the original. Useful 53 | for implementing the COPY? semantics of methods." 54 | (if copy? 55 | (copy-array array) 56 | array)) 57 | 58 | (defun convex-combination (a b alpha) 59 | "Convex combination (1-alpha)*a+alpha*b." 60 | (+ (* (- 1 alpha) a) (* alpha b))) 61 | 62 | (defun vector-last (vector &optional (n 1)) 63 | "Like LAST, but for vectors." 64 | (aref vector (- (length vector) n))) 65 | 66 | (defun common (sequence &key (key #'identity) (test #'eql) failure error) 67 | "If the elements of sequence are the same (converted with KEY, compared with 68 | TEST), return that, otherwise FAILURE. When ERROR?, an error is signalled 69 | instead. The second value is true iff elements are the same." 70 | (values 71 | (reduce (lambda (a b) 72 | (if (funcall test a b) 73 | a 74 | (if error 75 | (apply #'error (ensure-list error)) 76 | (return-from common failure)))) 77 | sequence 78 | :key key) 79 | t)) 80 | 81 | (defun common-length (&rest sequences) 82 | "If sequences have the same length, return that, otherwise NIL." 83 | (common sequences :key #'length :test #'=)) 84 | 85 | (defun common-dimensions (&rest arrays) 86 | "If arrays have the same dimensions, return that, otherwise NIL." 87 | (common arrays :key #'array-dimensions :test #'equalp)) 88 | 89 | (defun format-number (number &key (int-digits 3) (exp-digits 1)) 90 | "Format number nicely." 91 | (if (integerp number) 92 | (format nil "~d" number) 93 | (format nil "~,v,v,,g" int-digits exp-digits number))) 94 | 95 | (defun ignore-error (function &key replacement-value) 96 | "Wrap function to return REPLACEMENT-VALUE in case of errors." 97 | ;; ?? maybe write a compiler macro 98 | (lambda (&rest arguments) 99 | (handler-case (apply function arguments) 100 | (error () replacement-value)))) 101 | 102 | (defun ignore-nil (function) 103 | "Wrap FUNCTION in a closure that returns NIL in case any of the arguments 104 | are NIL." 105 | (lambda (&rest arguments) 106 | (when (every #'identity arguments) 107 | (apply function arguments)))) 108 | 109 | (defun text-progress-bar (stream n &key 110 | (character #\*) (length 80) 111 | (deciles? t) (before "~&[") (after "]~%")) 112 | "Return a closure that displays a progress bar when called with 113 | increments (defaults to 1). When the second argument is T, index will be set 114 | to the given value (instead of a relative change). 115 | 116 | LENGTH determines the number of CHARACTERs to display (not including AFTER and 117 | BEFORE, which are displayed when the closure is first called and after the 118 | index reaches N, respectively). When DECILES?, characters at every decile 119 | will be replaced by 0,...,9. 120 | 121 | When STREAM is NIL, nothing is displayed." 122 | (unless stream 123 | (return-from text-progress-bar (lambda ()))) 124 | (let* ((characters (aprog1 (make-string length :initial-element character) 125 | (when deciles? 126 | (loop for index :below 10 do 127 | (replace it (format nil "~d" index) 128 | :start1 (floor (* index length) 10)))))) 129 | (index 0) 130 | (position 0)) 131 | (lambda (&optional (increment 1) absolute?) 132 | (when before 133 | (format stream before) 134 | (setf before nil)) 135 | (if absolute? 136 | (progn 137 | (assert (<= index increment) () "Progress bar can't rewind.") 138 | (setf index increment)) 139 | (incf index increment)) 140 | (assert (<= index n) () "Index ran above total (~A > ~A)." index n) 141 | (let ((target-position (floor (* index length) n))) 142 | (loop while (< position target-position) do 143 | (princ (aref characters position) stream) 144 | (incf position))) 145 | (when (and (= index n) after) 146 | (format stream after))))) 147 | 148 | (defmacro define-indirect-accessors (specializer slot-accessor 149 | &rest accessors) 150 | "Define accessor methods for specializer going though a slot." 151 | (with-unique-names (instance) 152 | `(progn 153 | ,@(loop for accessor in accessors collect 154 | `(defmethod ,accessor ((,instance ,specializer)) 155 | (,accessor (,slot-accessor ,instance))))))) 156 | 157 | (defgeneric keys-and-values (object) 158 | (:documentation "Return a vector of (cons KEY VALUE) in OBJECT (eg a 159 | hash-table).") 160 | (:method ((object hash-table)) 161 | (let* ((size (hash-table-count object)) 162 | (result (make-array size)) 163 | (index 0)) 164 | (maphash (lambda (key value) 165 | (setf (aref result index) (cons key value)) 166 | (incf index)) 167 | object) 168 | result))) 169 | 170 | ;;;; Thinning 171 | ;;; 172 | ;;; Thinning is always by a uniform step interval. 173 | 174 | (defun thinned-length% (length thinning &optional (start 0)) 175 | "Internal function for calculating the thinned length." 176 | (ceiling (- length start) thinning)) 177 | 178 | (defun thin (vector thinning &optional (start 0)) 179 | "Thin vector, keeping every THINNING element, starting at START." 180 | (let* ((n (length vector)) 181 | (m (thinned-length% n thinning start)) 182 | (result (make-array m :element-type (array-element-type vector)))) 183 | (loop for index below m 184 | do (setf (aref result index) (aref vector start)) 185 | (incf start thinning)) 186 | result)) 187 | 188 | (defun thin-to (vector length &optional (rounding :closest)) 189 | "Thin close to the desired length. ROUNDING can be :CLOSEST, :BELOW, 190 | and :ABOVE, which determines how the length of the result is selected relative 191 | to the desired length." 192 | (let+ ((vector-length (length vector)) 193 | (above (floor vector-length length)) 194 | (below (ceiling vector-length length))) 195 | (thin vector (ecase rounding 196 | (:below below) 197 | (:above above) 198 | (:closest 199 | (if (< (- length (thinned-length% vector-length below)) 200 | (- (thinned-length% vector-length above) length)) 201 | below 202 | above)))))) 203 | -------------------------------------------------------------------------------- /src/old/optimization.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils) 4 | 5 | (defun golden-section-combination (a b) 6 | "Return the convex combination (1-G)*a+G*b, where G is the 7 | inverse of the golden ratio." 8 | (+ (* #.(- 1d0 (/ (- 3d0 (sqrt 5d0)) 2d0)) a) 9 | (* #.(/ (- 3d0 (sqrt 5d0)) 2d0) b))) 10 | 11 | (defun golden-section-minimize (f a b tol &optional (max-iter 100)) 12 | "Find a local minimum of F in the [A,B] interval. The algorithm terminates 13 | when the minimum is bracketed in an interval smaller than TOL. Since the 14 | algorithm is slow, TOL should not be chosen smaller then necessary. The 15 | algorithm will also find the local minimum at the endpoints, and if F is 16 | unimodal, it will find the global minimum. MAX-ITER is there for terminating 17 | the algorithm, in case tolerance is zero or too small. All values (except 18 | max-iter) should be double-float, and F should be of 19 | type (FUNCTION (DOUBLE-FLOAT) DOUBLE-FLOAT). 20 | 21 | Note: when F is constant on a range, golden-section-minimize ``pulls 22 | to the left'', ie will keep picking smaller values." 23 | (declare (double-float a b tol) 24 | (fixnum max-iter) 25 | (type (function (double-float) double-float) f) 26 | (inline golden-section-combination) 27 | (optimize speed (safety 1))) 28 | ;; reorder a and b if necessary 29 | (when (> a b) 30 | (rotatef a b)) 31 | ;; start iteration with golden ratio inner points 32 | (let* ((m1 (golden-section-combination a b)) 33 | (m2 (golden-section-combination b a)) 34 | (f1 (funcall f m1)) 35 | (f2 (funcall f m2))) 36 | (declare (double-float m1 m2 f1 f2)) 37 | (iter 38 | (repeat max-iter) 39 | (declare (iterate:declare-variables)) 40 | (when (<= (abs (- b a)) tol) 41 | (return-from golden-section-minimize 42 | (if (< f1 f2) ; change < to maximize 43 | (values m1 f1) 44 | (values m2 f2)))) 45 | (if (<= f1 f2) ; change <= to maximize 46 | (progn 47 | ;; new bracket is (a,m1,m2) 48 | (shiftf b m2 m1 (golden-section-combination m1 a)) 49 | (shiftf f2 f1 (funcall f m1))) 50 | (progn 51 | ;; new bracket is (m1,m2,b) 52 | (shiftf a m1 m2 (golden-section-combination m2 b)) 53 | (shiftf f1 f2 (funcall f m2))))) 54 | (error 'reached-maximum-iterations :n max-iter))) 55 | 56 | ;; (defun linesearch-backtrack (g g0 gp0 alpha delta &key 57 | ;; (rel-min 0.1d0) (rel-max 0.5d0) (c 1d-4) 58 | ;; (max-iter 100)) 59 | ;; "Find alpha such that g(alpha) <= g(0) + c g'(0) alpha. 60 | 61 | ;; Parameters: G: the function g, G0: g(0), GP0: g'(0), ALPHA: initial alpha, 62 | ;; usually 1, for quasi-Newton methods, DELTA is the threshold for being too close 63 | ;; to 0 (perhaps indicating convergence). C is as above. Uses the backtracking 64 | ;; method." 65 | ;; (check-types double-float g0 gp0 alpha delta rel-min rel-max c) 66 | ;; (assert (plusp alpha)) 67 | ;; (assert (< 0d0 delta alpha)) 68 | ;; (assert (plusp c) () "C should be positive.") 69 | ;; (assert (minusp g0) () "Nonnegative g'(0).") 70 | ;; (let (alpha-prev 71 | ;; g-alpha-prev 72 | ;; (slope (* gp0 c))) ; line for sufficient decrease 73 | ;; (iter 74 | ;; (repeat max-iter) 75 | ;; (let ((g-alpha (funcall g alpha))) 76 | ;; ;; found satisfactory value 77 | ;; (when (<= g-alpha (+ g0 (* slope alpha))) 78 | ;; (return-from linesearch-backtrack alpha)) 79 | ;; ;; below delta, possible convergence 80 | ;; (when (<= alpha delta) 81 | ;; (return-from linesearch-backtrack 0)) 82 | ;; ;; calculate next step 83 | ;; (let* ((alpha-next 84 | ;; (if alpha-prev 85 | ;; ;; cubic approximation 86 | ;; (let* ((r (- g-alpha (* gp0 alpha) g0)) 87 | ;; (r-prev (- g-alpha-prev (* gp0 alpha-prev) g0)) 88 | ;; (alpha-diff (- alpha alpha-prev)) 89 | ;; (s (expt alpha 2)) 90 | ;; (s-prev (expt alpha-prev 2)) 91 | ;; (a (/ (- (/ r s) (/ r-prev s-prev)) alpha-diff)) 92 | ;; (b (/ (- (/ (* alpha r-prev) s-prev) 93 | ;; (/ (* alpha-prev r) s)) 94 | ;; alpha-diff))) 95 | ;; (if (zerop a) 96 | ;; (- (/ gp0 b 2d0)) 97 | ;; (let ((discriminant (- (expt b 2d0) (* 3 a gp0)))) 98 | ;; (cond 99 | ;; ;; a guess, will be regularized anyway 100 | ;; ((minusp discriminant) alpha) 101 | ;; ;; positive b: take left root 102 | ;; ((plusp b) (/ (- gp0) (+ b (sqrt discriminant)))) 103 | ;; ;; negative b: take right root 104 | ;; (t (/ (- (sqrt discriminant) b) a 3d0)))))) 105 | ;; ;; quadratic approximation 106 | ;; (- (/ (* gp0 (square alpha)) 107 | ;; (- g-alpha g0 (* alpha gp0)) 2d0))))) 108 | ;; (setf alpha-prev alpha 109 | ;; g-alpha-prev g-alpha 110 | ;; alpha (min (max (* alpha rel-min) 111 | ;; alpha-next) 112 | ;; (* alpha rel-max)))))) 113 | ;; (error 'reached-max-iter))) 114 | -------------------------------------------------------------------------------- /src/old/pretty.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils) 4 | 5 | (defun real-epsilon (number) 6 | "Return the `machine epsilon' for the type of number (only the type is used, not the value). For complex numbers, return the epsilon of the corresponding real type, for rationals, the epsilon is that of a single float." 7 | (etypecase number 8 | (short-float short-float-epsilon) 9 | (single-float single-float-epsilon) 10 | (double-float double-float-epsilon) 11 | (long-float long-float-epsilon) 12 | (rational single-float-epsilon) 13 | (complex (real-epsilon (realpart number))))) 14 | 15 | (defparameter *default-min-step-correction* 100 16 | "Default multiplier for correcting the machine epsilon.") 17 | 18 | (defun default-min-step (width) 19 | "Default minimum step." 20 | (* *default-min-step-correction* (real-epsilon width))) 21 | 22 | (defparameter *pretty-bias* 0d0 23 | "Default bias for PRETTY-STEP.") 24 | 25 | (defparameter *pretty-five-bias* 0.1d0 26 | "Default bias to 5's for PRETTY-STEP.") 27 | 28 | (defun pretty (x &key (bias *pretty-bias*) (five-bias *pretty-five-bias*)) 29 | "Return a rational that is close to x, and is a multiple of 1, 2 or 5 times a power of 10. The logarithm is taken, to which BIAS is added. The result will be based on the fractional part. FIVE-BIAS, also interpreted on a log scale, favors 5 over 2 as the first digit. When BIAS favors larger values." 30 | (let+ (((&values exponent residual) 31 | (floor (+ (coerce (log x 10) 'double-float) bias))) 32 | (correction (cond 33 | ((<= residual (- #.(log 2d0 10) five-bias)) 2) 34 | ((<= residual #.(log 5d0 10)) 5) 35 | (t 10)))) 36 | (values (* correction (expt 10 exponent)) 37 | (max 0 (- (if (= correction 10) -1 0) exponent))))) 38 | 39 | (defun pretty-step (width n &key 40 | (min-step (default-min-step width)) 41 | (bias *pretty-bias*) 42 | (five-bias *pretty-five-bias*)) 43 | "Return a `pretty' (meaning 1, 2, or 5*10^n) step size, and the number of fractional digits as the second value. Uses PRETTY, but enforces a minimum. When BIAS is 0,, STEP always divides WIDTH to at most N intervals." 44 | (pretty (max (/ width (1+ n)) min-step) :bias bias :five-bias five-bias)) 45 | -------------------------------------------------------------------------------- /src/old/sparse-array.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils) 4 | 5 | (defclass sparse-array () 6 | ((elements :accessor elements :initarg :elements 7 | :initform (make-hash-table :test #'equal)) 8 | (limits :accessor limits :initarg :limits) 9 | (initial-value :accessor initial-value :initarg :initial-value :initform nil)) 10 | (:documentation "Sparse arrays are indexed by a rectilinear coordinate system. Unless set, elements are left at their initial value. If initial-value is a function, it is called with the subscripts to initialize the elements.")) 11 | 12 | (defun sparse-array-extend-limits (limits subscripts) 13 | "Extend limits to incorporate subscripts. Does error checking on the length of subscripts." 14 | (let ((rank (length limits))) 15 | (assert (= rank (length subscripts))) 16 | (loop :for index :below rank 17 | :for subscript :in subscripts 18 | :do (check-type subscript fixnum) 19 | (aif (aref limits index) 20 | (progn 21 | (minf (car it) subscript) 22 | (maxf (cdr it) (1+ subscript))) 23 | (setf (aref limits index) (cons subscript (1+ subscript))))))) 24 | 25 | (defun sparse-array-initial-value (initial-value subscripts) 26 | "Initial value semantics for sparse arrays -- functions are called with subscripts." 27 | (if (functionp initial-value) 28 | (apply initial-value subscripts) 29 | initial-value)) 30 | 31 | (defmethod initialize-instance :after ((sparse-array sparse-array) 32 | &key rank &allow-other-keys) 33 | (check-type rank (integer 0)) 34 | (setf (limits sparse-array) (make-array rank :initial-element nil))) 35 | 36 | (defmethod ref ((sparse-array sparse-array) &rest subscripts) 37 | (let+ (((&slots-r/o elements initial-value) sparse-array) 38 | ((&values value present?) (gethash subscripts elements))) 39 | (if present? 40 | value 41 | (sparse-array-initial-value initial-value subscripts)))) 42 | 43 | (defmethod (setf ref) (value (sparse-array sparse-array) &rest subscripts) 44 | (sparse-array-extend-limits (limits sparse-array) subscripts) 45 | (setf (gethash subscripts (elements sparse-array)) value)) 46 | -------------------------------------------------------------------------------- /src/old/unused.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils) 4 | 5 | (eval-when (:compile-toplevel :load-toplevel :execute) 6 | (error "This file contains functions which are not used at the moment, 7 | should not be loaded.")) 8 | 9 | ;; (defgeneric filter-rows (predicate object) 10 | ;; (:documentation "Filter rows of a matrix, with predicate applied to each row 11 | ;; as vectors (which should not be modified).") 12 | ;; (:method (predicate (object array)) 13 | ;; (sub object (which-rows predicate object) t))) ; SN: I believe 'sub' became 'slice/select'. which-rows might now be 'which' or 'df:mask-rows' 14 | 15 | ;; (defmacro with-filter-rows (matrix (&rest name-column-pairs) &body body) 16 | ;; "Use BODY to filter rows of MATRIX, binding NAMEs to the given COLUMNs. 17 | 18 | ;; Example: 19 | ;; (with-filter-rows #2A((0 1) 20 | ;; (101 80) 21 | ;; (203 200)) 22 | ;; ((a 0) 23 | ;; (b 1)) 24 | ;; (and (oddp a) (< 100 b))) ; => #2A((203 200))" 25 | ;; (with-unique-names (vector) 26 | ;; (let ((name-var-values (mapcar (lambda (name-column-pair) 27 | ;; (let+ (((name column) name-column-pair)) 28 | ;; (check-type name symbol) 29 | ;; (list name 30 | ;; (gensym (symbol-name name)) 31 | ;; column))) 32 | ;; name-column-pairs))) 33 | ;; `(let ,(mapcar #'cdr name-var-values) 34 | ;; (filter-rows (lambda (,vector) 35 | ;; (let ,(mapcar (lambda (name-var-value) 36 | ;; (let+ (((name var nil) name-var-value)) 37 | ;; `(,name (aref ,vector ,var)))) 38 | ;; name-var-values) 39 | ;; ,@body)) 40 | ;; ,matrix))))) 41 | 42 | ;; (defgeneric shrink-rows (matrix &key predicate) 43 | ;; (:documentation "Drop columns where no element satisfies predicate from both sides 44 | ;; of MATRIX. The default predicate is the identity function, ie columns of all NILs 45 | ;; are dropped. If no element satisfies PREDICATE, NIL is returned, otherwise the 46 | ;; shrunk array, the start index and the end index are returned as values.") 47 | ;; (:method ((matrix array) &key (predicate #'identity)) 48 | ;; (let+ (((nrow nil) (array-dimensions matrix))) 49 | ;; (iterate 50 | ;; (for row-index :below nrow) 51 | ;; (let* ((row (subarray matrix row-index)) 52 | ;; (row-left (position-if predicate row))) 53 | ;; (when row-left 54 | ;; (let ((row-right (position-if predicate row :from-end t))) 55 | ;; (minimize row-left :into left) 56 | ;; (maximize row-right :into right)))) 57 | ;; (finally 58 | ;; (return 59 | ;; (when (and left right) 60 | ;; (let ((end (1+ right))) 61 | ;; (values (sub matrix t (si left end)) left end))))))))) 62 | 63 | ;;; !! ROWS and COLUMNS could be speeded up considerably for Lisp arrays 64 | 65 | ;; (defgeneric rows (object &key copy?) 66 | ;; (:documentation "Return the rows of a matrix-like OBJECT as a vector. May 67 | ;; share structure unless COPY?.") 68 | ;; (:method ((matrix array) &key copy?) 69 | ;; (iter 70 | ;; (for row-index :below (nrow matrix)) 71 | ;; (collecting (subarray matrix row-index :copy? copy?) 72 | ;; :result-type vector))) 73 | ;; (:method (object &key copy?) 74 | ;; (rows (as-array object) :copy? copy?))) 75 | 76 | ;; (defgeneric columns (matrix &key copy?) 77 | ;; (:documentation "Return the columns of a matrix-like object as a vector of 78 | ;; vectors. May share structure unless COPY?.") 79 | ;; (:method ((matrix array) &key copy?) 80 | ;; (declare (ignore copy?)) 81 | ;; (iter 82 | ;; (for column-index :below (ncol matrix)) 83 | ;; (collecting (sub matrix t column-index) 84 | ;; :result-type vector))) 85 | ;; (:method (object &key copy?) 86 | ;; (columns (as-array object) :copy? copy?))) 87 | 88 | 89 | ;; (defgeneric map-rows (function matrix) 90 | ;; (:documentation "Map matrix row-wise into another matrix or vector, depending 91 | ;; on the element type returned by FUNCTION.")) 92 | 93 | ;; (defun map-subarrays (function array) 94 | ;; "Map subarrays along the first index, constructing a result array with . 95 | ;; Single-element subarrays are treated as atoms." 96 | ;; (let+ (((&values length get-subarray) 97 | ;; (if (vectorp array) 98 | ;; (values (length array) 99 | ;; (lambda (index) (aref array index))) 100 | ;; (values (nrow array) 101 | ;; (lambda (index) (subarray array index))))) 102 | ;; results 103 | ;; save-subarray) 104 | ;; (dotimes (index length) 105 | ;; (let ((result (funcall function (funcall get-subarray)))) 106 | ;; (when (zerop index) 107 | ;; (setf (values results save-subarray) 108 | ;; (if (arrayp result) 109 | ;; (values 110 | ;; (make-array (cons length (array-dimensions result)) 111 | ;; :element-type (array-element-type result)) 112 | ;; (lambda (index result) 113 | ;; (setf (subarray results index) result))) 114 | ;; (values (make-array length) 115 | ;; (lambda (index result) 116 | ;; (setf (aref results index) result)))))) 117 | ;; (funcall save-subarray index result))))) 118 | 119 | 120 | ;; (defgeneric create (type element-type &rest dimensions) 121 | ;; (:documentation "Create an object of TYPE with given DIMENSIONS and 122 | ;; ELEMENT-TYPE (or a supertype thereof).")) 123 | 124 | ;; (defmethod create ((type (eql 'array)) element-type &rest dimensions) 125 | ;; (make-array dimensions :element-type element-type)) 126 | 127 | ;; (defmethod collect-rows (nrow function &optional (type 'array)) 128 | ;; (let (result ncol) 129 | ;; (iter 130 | ;; (for row :from 0 :below nrow) 131 | ;; (let ((result-row (funcall function))) 132 | ;; (when (first-iteration-p) 133 | ;; (setf ncol (length result-row) 134 | ;; result (create type (array-element-type result-row) nrow ncol))) 135 | ;; (setf (sub result row t) result-row))) 136 | ;; result)) 137 | 138 | ;; (defun collect-vector (n function &optional (element-type t)) 139 | ;; (let (result) 140 | ;; (iter 141 | ;; (for index :from 0 :below n) 142 | ;; (let ((element (funcall function))) 143 | ;; (when (first-iteration-p) 144 | ;; (setf result (make-array n :element-type element-type))) 145 | ;; (setf (aref result index) element))) 146 | ;; result)) 147 | 148 | (defgeneric pref (object &rest indexes) 149 | (:documentation "Return a vector, with elements from OBJECT, extracted using 150 | INDEXES in parallel.")) 151 | 152 | (defmethod pref ((array array) &rest indexes) 153 | (let ((rank (array-rank array)) 154 | (element-type (array-element-type array))) 155 | (assert (= rank (length indexes))) 156 | (when (zerop rank) 157 | (return-from pref (make-array 0 :element-type element-type))) 158 | (let* ((length (length (first indexes))) 159 | (result (make-array length :element-type element-type))) 160 | (assert (every (lambda (index) (= (length index) length)) (cdr indexes))) 161 | (loop 162 | :for element-index :below length 163 | :do (setf (aref result element-index) 164 | (apply #'aref array 165 | (mapcar (lambda (index) (aref index element-index)) 166 | indexes)))) 167 | result))) 168 | 169 | ;; (defun sequence= (a b) 170 | ;; "Test equality of A and B elementwise (also tests that elements are 171 | ;; of the same type)." 172 | ;; (and (if (and (vectorp a) (vectorp b)) 173 | ;; (equal (array-element-type a) 174 | ;; (array-element-type b)) 175 | ;; (and (listp a) (listp b))) 176 | ;; (every #'eql a b))) 177 | 178 | ;; (addtest (seq-and-array-tests) 179 | ;; vector*-and-array* 180 | ;; (let+ ((*lift-equality-test* 181 | ;; (lambda (array spec) 182 | ;; "Test that array conforms to spec, which is (element-type array)." 183 | ;; (and (type= (array-element-type array) 184 | ;; (upgraded-array-element-type (first spec))) 185 | ;; (equalp array (second spec)))))) 186 | ;; (ensure-same (vector* 'fixnum 3 5 7) '(fixnum #(3 5 7))) 187 | ;; (ensure-same (array* '(2 3) 'double-float 188 | ;; 3 5 7 189 | ;; 11 13 17) 190 | ;; '(double-float #2A((3d0 5d0 7d0) (11d0 13d0 17d0)))))) 191 | 192 | ;; (addtest (seq-and-array-tests) 193 | ;; sequence= 194 | ;; (ensure-same (vector* 'double-float 1 2 3) 195 | ;; (vector* 'double-float 1 2.0 3d0)) 196 | ;; (ensure-same '(1 2 3) '(1 2 3)) 197 | ;; (ensure-different '(1d0 2 3) '(1 2 3)) 198 | ;; (ensure-different '(1 2 3) (vector* 'fixnum 1 2 3))) 199 | 200 | ;; (addtest (seq-and-array-tests) 201 | ;; seq 202 | ;; ;; missing :LENGTH (default :BY) 203 | ;; (ensure-same (numseq 0 5) 204 | ;; (vector* 'fixnum 0 1 2 3 4 5)) 205 | ;; ;; missing :TO 206 | ;; (ensure-same (numseq 1 nil :by 1/2 :length 3 :type 'list) 207 | ;; '(1 3/2 2)) 208 | ;; ;; missing :FROM 209 | ;; (ensure-same (numseq nil 9 :by 1d0 :length 4) 210 | ;; (vector* 'double-float 6d0 7d0 8d0 9d0)) 211 | ;; ;; missing :LENGTH, automatic direction for :by 212 | ;; (ensure-same (numseq 9 8 :by 0.5 :type 'list) 213 | ;; '(9.0 8.5 8.0)) 214 | ;; (ensure-same (numseq 9 8 :by -0.5 :type 'list) 215 | ;; '(9.0 8.5 8.0))) 216 | 217 | ;; (addtest (seq-and-array-tests) 218 | ;; map-array 219 | ;; (let ((a (map-array #'1+ (ia 3 4) 'fixnum)) 220 | ;; (*lift-equality-test* #'equalp)) 221 | ;; (ensure-same a (ia* 1 3 4)) 222 | ;; (ensure-same (array-element-type a) 'fixnum))) 223 | 224 | ;; (addtest (seq-and-array-tests) 225 | ;; vector-satisfies? 226 | ;; (ensure (vector-satisfies? #(1 2 3) #'<)) 227 | ;; (ensure (not (vector-satisfies? #(1 1 2) #'<))) 228 | ;; (ensure (not (vector-satisfies? #(3 2 1) #'<=))) 229 | ;; (ensure (vector-satisfies? #(1) #'<)) 230 | ;; (ensure (vector-satisfies? #() #'<)) 231 | ;; (ensure-error (vector-satisfies? 'not-a-vector #'<)) 232 | ;; (ensure-error (vector-satisfies? '(not a vector) #'<))) 233 | 234 | 235 | ;; (addtest (seq-and-array-tests) 236 | ;; group-test 237 | ;; (let ((*lift-equality-test* #'equalp) 238 | ;; (v6 #(0 1 2 3 4 5))) 239 | ;; (ensure-same (group v6 #(0 1 2 0 1 0)) 240 | ;; #(#(0 3 5) #(1 4) #(2))) 241 | ;; (ensure-same (group v6 #(0 1 2 0 1 0) #(0 1 0 0 1 1)) 242 | ;; #2A((#(0 3) #(5)) 243 | ;; (#() #(1 4)) 244 | ;; (#(2) #()))) 245 | ;; (ensure-error (group v6 #(1 2 3))) 246 | ;; (ensure-error (group v6 #(1 2 3 4 5 6) nil)))) 247 | 248 | ;; (addtest (array-tests) 249 | ;; map-rows 250 | ;; (ensure-same (map-rows #'sum (ia 4 3)) 251 | ;; #(3 12 21 30)) 252 | ;; (ensure-same (map-rows (lambda (col) (vector (sum col) (mean col))) (ia 4 3)) 253 | ;; #2A((3 1) 254 | ;; (12 4) 255 | ;; (21 7) 256 | ;; (30 10)))) 257 | -------------------------------------------------------------------------------- /src/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: CL-USER -*- 2 | ;;; Copyright (c) 2022 by Symbolics Pte. Ltd. All rights reserved. 3 | 4 | (uiop:define-package #:num-utils 5 | (:nicknames :nu) 6 | (:documentation "Numerical utilities for Lisp-Stat") 7 | (:use :common-lisp) 8 | (:use-reexport #:num-utils.arithmetic 9 | #:num-utils.chebyshev 10 | #:num-utils.elementwise 11 | #:num-utils.interval 12 | #:num-utils.matrix 13 | #:num-utils.num= 14 | #:num-utils.utilities 15 | #:num-utils.rootfinding 16 | #:num-utils.polynomial 17 | #:num-utils.test-utilities 18 | #:num-utils.quadrature 19 | #:num-utils.log-exp 20 | #:num-utils.print-matrix 21 | #:num-utils.matrix-shorthand)) 22 | -------------------------------------------------------------------------------- /src/polynomial.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.POLYNOMIAL -*- 2 | ;;; Copyright (c) 2011-2014 Tamas Papp 3 | ;;; Copyright (c) 2023 Symbolics Pte Ltd 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | (uiop:define-package #:num-utils.polynomial 7 | (:use #:cl 8 | #:alexandria 9 | #:num-utils.utilities) 10 | (:nicknames #:poly) 11 | (:export #:evaluate-polynomial #:evaluate-rational) 12 | (:documentation "Efficient evaluation of polynomial functions using Horner's method")) 13 | (in-package #:num-utils.polynomial) 14 | 15 | 16 | ;;; If this turns out to have poor performance, see 17 | ;;; https://github.com/ruricolist/horner or the assembler version from 18 | ;;; Cephes 19 | 20 | ;;; Expect optimisation notes here for FIXNUM and T branches. T 21 | ;;; branch could probably be removed, as it covers relatively few use 22 | ;;; cases. 23 | (declaim (inline evaluate-polynomial)) 24 | (defun evaluate-polynomial (coefficients x) 25 | "Return the sum of polynomials, weighted by COEFFICIENTS, at X. 26 | COFFICIENTS are ordered from the highest degree down to the constant term. 27 | X must be of the same type as COEFFICIENTS." 28 | (declare (optimize(speed 3)(safety 1))) 29 | (typecase x 30 | (double-float 31 | (let ((sum 0d0)) 32 | (declare (double-float sum x) 33 | (simple-double-float-vector coefficients)) 34 | (dotimes (index (the fixnum (length coefficients))) 35 | (the double-float (setf sum (+ (aref coefficients index) 36 | (* x sum))))) 37 | (the double-float sum))) 38 | (single-float 39 | (let ((sum 0s0)) 40 | (declare (single-float sum x) 41 | (simple-single-float-vector coefficients)) 42 | (dotimes (index (the fixnum (length coefficients))) 43 | (setf sum (+ (aref coefficients index) 44 | (* x sum)))) 45 | sum)) 46 | (fixnum ; The usefulness of optimising this branch is doubtful, 47 | ; since we cannot guarantee the result is a fixnum 48 | (let ((sum 0)) 49 | (declare (fixnum sum x) 50 | (simple-fixnum-vector coefficients)) 51 | (dotimes (index (the fixnum (length coefficients))) 52 | (setf sum (+ (aref coefficients index) 53 | (the fixnum (* x sum))))) 54 | sum)) 55 | (t ; Here for completeness 56 | (let ((sum 0)) 57 | (declare (vector coefficients)) 58 | (dotimes (index (the fixnum (length coefficients))) 59 | (setf sum (+ (aref coefficients index) 60 | (* x sum)))) 61 | sum)))) 62 | 63 | 64 | 65 | ;;; 66 | ;;; Evaluate ratios of polynomial functions 67 | ;;; 68 | 69 | ;;; See https://www.boost.org/doc/libs/1_68_0/libs/math/doc/html/math_toolkit/tuning.html 70 | ;;; https://en.wikipedia.org/wiki/Rational_function 71 | ;;; See: https://www.boost.org/doc/libs/1_76_0/boost/math/tools/rational.hpp" 72 | 73 | ;;; Note that the order of the coefficients here differs from 74 | ;;; evaluate-polynomial. Here it is from the constant term up to the 75 | ;;; highest order polynomial. This is because evaluate-polynomial was 76 | ;;; taken from Cephes, which orders coefficients highest->lowest, and 77 | ;;; evaluate-rational was taken from Boost, which orders them 78 | ;;; lowest->highest 79 | 80 | (defun evaluate-rational (numerator denominator z) 81 | "Evaluate a rational function using Horner's method. NUMERATOR and DENOMINATOR must be equal in size. These always have a loop and so may be less efficient than evaluating a pair of polynomials. However, there are some tricks we can use to prevent overflow that might otherwise occur in polynomial evaluation if z is large. This is important in our Lanczos code for example. 82 | 83 | N.B. The order of coefficients for this function is NOT the same as evaluate-polynomial. " 84 | (assert (= (length numerator) 85 | (length denominator)) () "Numerator and denominator must be the same length") 86 | (let (s1 s2) 87 | (if (<= z 1) 88 | (progn 89 | (setf s1 (last-elt numerator) 90 | s2 (last-elt denominator)) 91 | (loop for i from (- (length numerator) 2) downto 0 92 | do (setf s1 (* s1 z) 93 | s1 (+ s1 (aref numerator i)) 94 | s2 (* s2 z) 95 | s2 (+ s2 (aref denominator i))))) 96 | (progn 97 | (setf z (/ z) 98 | s1 (first-elt numerator) 99 | s2 (first-elt denominator)) 100 | (loop for i from 1 below (length numerator) 101 | do (setf s1 (* s1 z) 102 | s1 (+ s1 (aref numerator i)) 103 | s2 (* s2 z) 104 | s2 (+ s2 (aref denominator i)))))) 105 | (/ s1 s2))) 106 | 107 | 108 | 109 | 110 | #| Implementation Notes 111 | 112 | [1] From a discussion on the CCL mailing list, this was a message from 113 | Stas Boukarev, one of the SBCL maintainers, when I asked about using 114 | assert like this: 115 | 116 | (assert (and (plusp (length coefficients)) 117 | (every (lambda (elt) 118 | (typep elt (class-of x))) 119 | coefficients)) 120 | (coefficients x) 121 | "Coefficients and X must be of the same type.") 122 | 123 | so that I could declare the variables in the loop for evaluate-polynomial. 124 | 125 | "Are you doing it for performance? Any performance gains you get from 126 | declaring your variables in a loop will be destroyed by performing 127 | typep at runtime. 128 | The cost of determining type-of, parsing it and applying typep on it 129 | is going to be very high, especially if it's done on every element of 130 | a sequence. 131 | If you do need to perform that operation, you can do 132 | (defun foo (x sequence) 133 | (macrolet ((make-test (x types) 134 | `(etypecase ,x 135 | ,@(loop for type in types 136 | collect `(,type (lambda (x) (typep x ',type))))))) 137 | (every (make-test x (double-float single-float fixnum)) 138 | sequence)))" 139 | 140 | Maybe even putting EVERY inside the expansion, to get better inlining. 141 | And handle specialized arrays without going through each element. 142 | 143 | |# 144 | -------------------------------------------------------------------------------- /src/print-matrix.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.PRINT-MATRIX -*- 2 | ;;; Copyright (c) 2011-2014 Tamas Papp 3 | ;;; Copyright (c) 2023 Symbolics Pte Ltd 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | (uiop:define-package #:num-utils.print-matrix 7 | (:use #:cl 8 | #:alexandria 9 | #:anaphora 10 | #:let-plus) 11 | (:export 12 | #:print-length-truncate 13 | #:*print-matrix-precision* 14 | #:print-matrix)) 15 | (in-package #:num-utils.print-matrix) 16 | 17 | 18 | (defun print-length-truncate (dimension) 19 | "Return values (min dimension *print-length*) and whether the constraint is binding." 20 | (if (or (not *print-length*) (<= dimension *print-length*)) 21 | (values dimension nil) 22 | (values *print-length* t))) 23 | 24 | (defvar *print-matrix-precision* 5 25 | "Number of digits after the decimal point when printing numeric matrices.") 26 | 27 | (defun print-matrix-formatter (x) 28 | "Standard formatter for matrix printing. Respects *print-precision*, and formats complex numbers as a+bi, eg 0.0+1.0i." 29 | ;; ?? do we want a complex numbers to be aligned on the +, like R? I 30 | ;; am not sure I like that very much, and for a lot of data, I would 31 | ;; visualize it graphically anyhow (I hate tables of 7+ numbers in 32 | ;; general). -- Tamas, 2009-sep-13 33 | (let ((precision *print-matrix-precision*)) 34 | (typecase x 35 | (integer (format nil "~d" x)) 36 | (real (format nil "~,vf" precision x)) 37 | (complex (format nil "~,vf+~,vfi" 38 | precision (realpart x) 39 | precision (imagpart x))) 40 | (t (format nil "~a" x))))) 41 | 42 | (defun print-matrix (matrix stream 43 | &key (formatter #'print-matrix-formatter) 44 | (masked-fn (constantly nil)) 45 | (aligned? t) 46 | (padding " ") 47 | (indent " ")) 48 | "Format and print the elements of MATRIX (a 2d array) to STREAM, using PADDING between columns. 49 | 50 | MASKED-FN is called on row and column indices. If it returns nil, the corresponding element is formatted using FORMATTER and printed. Otherwise, it should return a string, which is printed as is. INDENT is printed before each row. 51 | 52 | If ALIGNED?, columns will be right-aligned. At most *PRINT-LENGTH* rows and columns are printed, more is indicated with ellipses (...)." 53 | ;; QUESTION maybe column & row labels, not a high priority at the moment 54 | (let+ (((&values nrow row-trunc?) (print-length-truncate (aops:nrow matrix))) 55 | ((&values ncol col-trunc?) (print-length-truncate (aops:ncol matrix))) 56 | (formatted-elements (make-array (list nrow ncol))) 57 | (column-widths (make-array ncol :element-type 'fixnum :initial-element 0))) 58 | ;; first pass - format elements, measure width 59 | (dotimes (col ncol) 60 | (dotimes (row nrow) 61 | (let+ ((masked? (funcall masked-fn row col)) 62 | (formatted-element (aif masked? 63 | it 64 | (funcall formatter (aref matrix row col)))) 65 | (width (length formatted-element))) 66 | (maxf (aref column-widths col) width) 67 | (setf (aref formatted-elements row col) formatted-element)))) 68 | ;; second pass - print 69 | (dotimes (row nrow) 70 | (when (plusp row) 71 | (fresh-line stream)) 72 | (format stream indent) 73 | (dotimes (col ncol) 74 | (when (plusp col) 75 | (princ padding stream)) 76 | (let ((elt (aref formatted-elements row col))) 77 | (if aligned? 78 | (format stream "~V@A" (aref column-widths col) elt) 79 | (princ elt stream)))) 80 | (when col-trunc? 81 | (princ padding stream) 82 | (princ "..." stream))) 83 | (when row-trunc? 84 | (format stream "~&...")))) 85 | 86 | ;;; Sometimes we want an unwrapped matrix (rank 2 array) to be printed 87 | ;;; in human, as opposed to machine, readable format. For this we need 88 | ;;; to overide the implementation's print-object method. Here's how to 89 | ;;; do that for SBCL: 90 | #| 91 | (defun output-matrix (array stream) 92 | (print-unreadable-object (array stream :type t) 93 | (format stream "~%") 94 | (print-matrix array stream))) 95 | 96 | From SBCL:print.lisp 97 | (defmethod sb-impl::print-object ((array array) stream) 98 | (if (and (or *print-array* *print-readably*) (array-element-type array)) 99 | (if (= 2 (array-rank array)) 100 | (output-matrix array stream) 101 | (sb-impl::output-array-guts array stream)) 102 | (sb-impl::output-terse-array array stream))) 103 | |# 104 | -------------------------------------------------------------------------------- /src/quadrature.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.QUADRATURE -*- 2 | ;;; Copyright (c) 2011-2014 Tamas Papp 3 | ;;; Copyright (c) 2023 Symbolics Pte Ltd 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | (uiop:define-package #:num-utils.quadrature 7 | (:use #:cl 8 | #:alexandria 9 | #:alexandria+ 10 | #:anaphora 11 | #:num-utils.arithmetic 12 | #:num-utils.interval 13 | #:num-utils.utilities 14 | #:let-plus) 15 | (:export #:romberg-quadrature)) 16 | (in-package #:num-utils.quadrature) 17 | 18 | ;;;; Richardson extrapolation (general framework) 19 | 20 | (defstruct (richardson-extrapolation 21 | (:constructor richardson-extrapolation 22 | (coefficient iterations 23 | &aux (diagonal (make-array iterations 24 | :element-type 'double-float))))) 25 | "Given A(h)=A_0 + \sum_{k=1}^\infty a_k h^{kp}, calculate approximations for A given A(h q^{-k}), where the latter can be incorporated using RICHARDSON-ITERATION with consecutive values for k=1,...,max_iter, which returns the latest A(0) as the first and the largest relative change, which can be used to test termination. 26 | 27 | The algorithm uses Richardson extrapolation, the required coefficient is q^k." 28 | (coefficient nil :type double-float) 29 | (n 0 :type fixnum) 30 | (diagonal nil :type (array double-float (*)))) 31 | 32 | (defun richardson-iteration (extrapolation step) 33 | "Add STEP (= $A(h q^{-k}$) to an existing Richardson EXTRAPOLATION. See the documentation of RICHARDSON-EXTRAPOLATION for details." 34 | (let+ (((&structure-r/o richardson-extrapolation- coefficient n diagonal) 35 | extrapolation) 36 | (largest-relative-change 0d0) 37 | (step (coerce step 'double-float))) 38 | (when (= n (length diagonal)) 39 | (error 'reached-maximum-iterations :n n)) 40 | (loop with product := coefficient 41 | for m from 0 below n 42 | do (let ((correction (/ (- step (aref diagonal m)) 43 | (1- product)))) 44 | (setf (aref diagonal m) step) 45 | (maxf largest-relative-change (/ (abs correction) (abs step))) 46 | (incf step correction) 47 | (multf product coefficient))) 48 | (setf (aref diagonal n) step) 49 | (incf (richardson-extrapolation-n extrapolation)) 50 | (values step largest-relative-change))) 51 | 52 | ;;;; iterative quadrature: generic interface 53 | 54 | (defstruct iterative-quadrature 55 | "Quadrature building block. 56 | 57 | F is the function. 58 | 59 | A and B are the endpoints. 60 | 61 | H is the stepsize." 62 | (f nil :type (function (double-float) double-float)) 63 | (a nil :type double-float) 64 | (b nil :type double-float) 65 | (h nil :type double-float) 66 | (n 0 :type fixnum) 67 | (sum 0d0 :type double-float)) 68 | 69 | (defgeneric refine-quadrature (quadrature) 70 | (:documentation "Refine quadrature with more points. Return the sum for those points.")) 71 | 72 | (defgeneric richardson-coefficient (quadrature) 73 | (:documentation "Return the coefficient $q$ for Richardson approximation.")) 74 | 75 | ;;; trapezoidal quadrature 76 | 77 | (defstruct (trapezoidal-quadrature 78 | (:include iterative-quadrature) 79 | (:constructor trapezoidal-quadrature%))) 80 | 81 | (defun trapezoidal-quadrature (f a b) 82 | (with-double-floats (a b) 83 | (trapezoidal-quadrature% :f f :a a :b b :h (- b a)))) 84 | 85 | (defmethod refine-quadrature ((quadrature trapezoidal-quadrature)) 86 | (let+ (((&structure-r/o iterative-quadrature- a b f) quadrature) 87 | ((&structure iterative-quadrature- n h sum) quadrature)) 88 | (setf sum 89 | (if (zerop n) 90 | (* (+ (funcall f a) (funcall f b)) h 0.5d0) 91 | (+ (/ sum 2) 92 | (let* ((h h)) 93 | (* h 94 | (loop 95 | repeat (expt 2 (1- n)) 96 | for x from (+ a h) by (* 2 h) 97 | summing (funcall f x))))))) 98 | (incf n) 99 | (multf h 1/2) 100 | sum)) 101 | 102 | (defmethod richardson-coefficient ((quadrature trapezoidal-quadrature)) 103 | 4d0) 104 | 105 | ;;; midpoint quadrature 106 | 107 | (defstruct (midpoint-quadrature 108 | (:include iterative-quadrature) 109 | (:constructor midpoint-quadrature%))) 110 | 111 | (defun midpoint-quadrature (f a b) 112 | (with-double-floats (a b) 113 | (midpoint-quadrature% :f f :a a :b b :h (- b a)))) 114 | 115 | (defmethod refine-quadrature ((quadrature midpoint-quadrature)) 116 | ;; (declare (optimize speed)) 117 | (let+ (((&structure-r/o iterative-quadrature- a b f) quadrature) 118 | ((&structure iterative-quadrature- n h sum) quadrature)) 119 | (setf sum 120 | (if (zerop n) 121 | (* h (+ (funcall f (/ (+ a b) 2)))) 122 | (+ (/ sum 3) 123 | (let* ((h h) 124 | (2h (* 2 h)) 125 | (s 0d0)) 126 | (loop 127 | repeat (expt 3 (1- n)) 128 | with x = (+ a (/ h 2)) 129 | do (incf s (funcall f x)) 130 | (incf x 2h) 131 | (incf s (funcall f x)) 132 | (incf x h)) 133 | (* h s))))) 134 | (incf n) 135 | (multf h 1/3) 136 | sum)) 137 | 138 | (defmethod richardson-coefficient ((quadrature midpoint-quadrature)) 139 | 9d0) 140 | 141 | ;;; implementation of Romberg quadrature 142 | 143 | (defun romberg-quadrature% (quadrature epsilon min-iter max-iter) 144 | "Internal function implementing Romberg quadrature. Requires an iterative quadrature instance, a relative EPSILON and MIN-ITER for the stopping criterion, and the maximum number of iterations allowed. Works on finite intervals." 145 | (loop with re = (richardson-extrapolation 146 | (richardson-coefficient quadrature) max-iter) 147 | do (let+ ((q (refine-quadrature quadrature)) 148 | ((&values q-extrapolated change) (richardson-iteration re q)) 149 | (n (richardson-extrapolation-n re))) 150 | (when (and (<= min-iter n) 151 | (<= change epsilon)) 152 | (return-from romberg-quadrature% (values q-extrapolated n)))))) 153 | 154 | (defgeneric transformed-quadrature (function interval transformation) 155 | (:documentation "Return a quadrature for integrating FUNCTION on INTERVAL, which may be infinite, in which case FUNCTION will be transformed. TRANSFORMATION can be used to select the transformation when applicable, otherwise it is NIL.") 156 | (:method (function (interval finite-interval) (transformation null)) 157 | (let+ (((&interval (a a-open?) (b b-open?)) interval)) 158 | (if (or a-open? b-open?) 159 | (midpoint-quadrature function a b) 160 | (trapezoidal-quadrature function a b)))) 161 | (:method (function (interval plusinf-interval) (transformation null)) 162 | (let+ (((&accessors-r/o left) interval)) 163 | (midpoint-quadrature (lambda (y) 164 | (let ((1-y (- 1 y))) 165 | (/ (funcall function (+ left (/ y 1-y))) 166 | (expt 1-y 2)))) 167 | 0 1)))) 168 | 169 | (defun romberg-quadrature (f interval &key (epsilon (sqrt double-float-epsilon)) 170 | (min-iter 5) 171 | (max-iter 20) 172 | transformation) 173 | "Romberg quadrature of F on the interval. The iteration stops if the relative change is below EPSILON, but only after MIN-ITER refinements (to avoid spurious premature convergence). An error occurs when MAX-ITER iterations are reached without convergence." 174 | (romberg-quadrature% (transformed-quadrature f interval transformation) 175 | epsilon min-iter max-iter)) 176 | -------------------------------------------------------------------------------- /src/rootfinding.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.ROOTFINDING -*- 2 | ;;; Copyright (c) 2011-2014 Tamas Papp 3 | ;;; Copyright (c) 2023 Symbolics Pte Ltd 4 | ;;; SPDX-License-identifier: MS-PL 5 | 6 | (uiop:define-package #:num-utils.rootfinding 7 | (:use #:cl 8 | #:alexandria 9 | #:num-utils.interval 10 | #:num-utils.utilities 11 | #:let-plus) 12 | (:export #:*rootfinding-epsilon* 13 | #:*rootfinding-delta-relative* 14 | #:root-bisection)) 15 | (in-package #:num-utils.rootfinding) 16 | 17 | ;;; Testing convergence of rootfinding methods 18 | 19 | (defun opposite-sign? (a b) 20 | "Return true iff A and B are on opposite sides of 0." 21 | (or (and (minusp a) (plusp b)) 22 | (and (plusp a) (minusp b)))) 23 | 24 | (defun narrow-bracket? (a b delta) 25 | "Return true iff $|a-b| < \\delta$." 26 | (< (abs (- a b)) delta)) 27 | 28 | (defun near-root? (f epsilon) 29 | "Return true iff $|f| < \\epsilon$." 30 | (< (abs f) epsilon)) 31 | 32 | (defparameter *rootfinding-epsilon* (expt double-float-epsilon 0.25) 33 | "Default maximum for the absolute value of the function, used for rootfinding.") 34 | 35 | (defparameter *rootfinding-delta-relative* (expt double-float-epsilon 0.25) 36 | "Default relative interval width for rootfinding.") 37 | 38 | (defun rootfinding-delta (interval 39 | &optional (delta-relative *rootfinding-delta-relative*)) 40 | "Default DELTA for rootfinding methods, uses bracket width." 41 | (* (interval-length interval) delta-relative)) 42 | 43 | ;;; convenience macro for various univariate rootfinders 44 | 45 | (defmacro univariate-rootfinder-loop% (((f a b fa fb) 46 | (f-tested test-bracket delta epsilon)) 47 | &body body) 48 | "Common parts for univariate rootfinder functions. 49 | 50 | Sets up the following: 51 | 52 | - function OPPOSITE-SIGN-P for checking that two numbers are on the opposite side of 0 53 | 54 | - function EVALUATE-AND-RETURN-IF-WITHIN-EPSILON which checks that |f(x)| <= EPSILON, if so, returns from the block with (VALUES X FX T), otherwise simply returns the value 55 | 56 | - function RETURN-IF-WITHIN-TOLERANCE checks if the interval [A,B] bracketing X is small enough (smaller than TOLERANCE) and if so, returns (X FX NIL (INTERVAL A B)) 57 | 58 | - variables FA and FB to hold function values at A and B 59 | 60 | Initially, it checks for either $f(a)$ or $f(b)$ being a root, and establishes $a \leq b$ by exchanging $a,f(a)$ and $b,f(b)$ if necessary. Also checks that $f(a)$ and $f(b)$ are of opposite sign. Checks that both tolerance and epsilon are nonnegative." 61 | (check-types (a b fa fb) symbol) 62 | (with-unique-names (block-name) 63 | (once-only (delta epsilon f) 64 | `(block ,block-name 65 | (flet ((,f-tested (x) 66 | (let ((fx (funcall ,f x))) 67 | (if (near-root? fx ,epsilon) 68 | (return-from ,block-name (values x fx t (interval ,a ,b))) 69 | fx))) 70 | (,test-bracket (fx x) 71 | (when (narrow-bracket? ,a ,b ,delta) 72 | (return-from ,block-name 73 | (values x fx nil ,a ,b))))) 74 | (assert (and (<= 0 ,delta) (<= 0 ,epsilon))) 75 | (when (< ,b ,a) 76 | (rotatef ,a ,b)) 77 | (let* ((,a (coerce ,a 'double-float)) 78 | (,b (coerce ,b 'double-float)) 79 | (,fa (,f-tested ,a)) 80 | (,fb (,f-tested ,b))) 81 | (unless (opposite-sign? ,fa ,fb) 82 | (error "Boundaries don't bracket 0.")) 83 | (loop 84 | ,@body))))))) 85 | 86 | (defun root-bisection (f bracket 87 | &key (delta (rootfinding-delta bracket)) 88 | (epsilon *rootfinding-epsilon*)) 89 | "Find the root of f bracketed between a and b using bisection. 90 | The algorithm stops when either the root is bracketed in an interval of length 91 | TOLERANCE (relative to the initial |a-b|), or root is found such that 92 | abs(f(root)) <= epsilon. 93 | 94 | Return five values: the root, the value of the function at the root, and a 95 | boolean which is true iff abs(f(root)) <= epsilon. If the third value is 96 | true, the fourth and fifth values are the endpoints of the bracketing 97 | interval, otherwise they are undefined." 98 | (let+ (((&interval a b) bracket)) 99 | (univariate-rootfinder-loop% ((f a b fa fb) 100 | (f-tested test-bracket delta epsilon)) 101 | (let* ((m (/ (+ a b) 2)) 102 | (fm (f-tested m))) 103 | (test-bracket fm m) 104 | (if (opposite-sign? fa fm) 105 | (setf b m 106 | fb fm) 107 | (setf a m 108 | fa fm)))))) 109 | 110 | ;; (defun root-ridders (f a b &key 111 | ;; (tolerance (* (abs (- b a)) #.(expt double-float-epsilon 0.25))) 112 | ;; (epsilon #.(expt double-float-epsilon 0.25))) 113 | ;; "Find the root of f bracketed between a and b using Ridders' method. 114 | ;; The algorithm stops when either the root is bracketed in an interval 115 | ;; of length tolerance, or root is found such that abs(f(root)) <= 116 | ;; epsilon. 117 | 118 | ;; Return five values: the root, the function evaluated at the root, and 119 | ;; a boolean which is true iff abs(f(root)) <= epsilon. If the third 120 | ;; value is true, the fourth and fifth values are the endpoints of the 121 | ;; bracketing interval, otherwise they are undefined." 122 | ;; ;; (declare (double-float a b tolerance epsilon) 123 | ;; ;; ((function (double-float) double-float) f)) 124 | ;; (univariate-rootfinder-common-setup root-ridders 125 | ;; (macrolet ((new-bracket (a b fa fb) 126 | ;; `(progn 127 | ;; (setf a ,a 128 | ;; b ,b 129 | ;; fa ,fa 130 | ;; fb ,fb) 131 | ;; (go top)))) 132 | ;; (tagbody 133 | ;; top 134 | ;; ;;; (format t "~a ~a~%" a b) 135 | ;; (let* ((m (half (+ a b))) ; midpoint 136 | ;; (fm (evaluate-and-return-if-within-epsilon m))) ; value at midpoint 137 | ;; (return-if-within-tolerance m fm a b) 138 | ;; (let* ((w (- (square fm) (* fa fb))) ; discriminant 139 | ;; (delta (/ (* (signum fa) fm (- b m)) (sqrt w))) ; c-m 140 | ;; (c (+ m delta)) ; interpolated guess 141 | ;; (fc (evaluate-and-return-if-within-epsilon c))) ; value at guess 142 | ;; (if (minusp delta) 143 | ;; ;; c < m 144 | ;; (cond 145 | ;; ((opposite-sign-p fm fc) (new-bracket c m fc fm)) 146 | ;; ((opposite-sign-p fa fc) (new-bracket a c fa fc)) 147 | ;; ((opposite-sign-p fb fc) (new-bracket c b fc fb)) 148 | ;; (t (error "internal error"))) 149 | ;; ;; m < c 150 | ;; (cond 151 | ;; ((opposite-sign-p fm fc) (new-bracket m c fm fc)) 152 | ;; ((opposite-sign-p fb fc) (new-bracket c b fc fb)) 153 | ;; ((opposite-sign-p fa fc) (new-bracket a c fa fc)) 154 | ;; (t (error "internal error")))))))))) 155 | 156 | 157 | 158 | ;; (defun find-satisfactory-fx (x f next-x-rule &key 159 | ;; (satisfactory-p #'minusp) 160 | ;; (maximum-iterations 100)) 161 | ;; "Try a sequence of x's (starting from x, generating the next one by 162 | ;; next-x-rule) until f(x) satisfies the predicate. Return (values x 163 | ;; fx). If maximum-iterations are reached, an error is signalled." 164 | ;; (dotimes (i maximum-iterations) 165 | ;; (let ((fx (funcall f x))) 166 | ;; (if (funcall satisfactory-p fx) 167 | ;; (return-from find-satisfactory-fx (values x fx)) 168 | ;; (setf x (funcall next-x-rule x))))) 169 | ;; ;; !!!! todo: decent error reporting with a condition 170 | ;; (error "reached maximum number of iterations")) 171 | 172 | 173 | ;; (defun make-expanding-rule (deltax multiplier) 174 | ;; "Creates a function that adds an ever-increasing (starting with 175 | ;; deltax, multiplied by multiplier at each step) to its argument. 176 | ;; Primarily for use with root-autobracket." 177 | ;; (assert (< 1 multiplier)) 178 | ;; (lambda (x) 179 | ;; (let ((new-x (+ x deltax))) 180 | ;; (multf deltax multiplier) 181 | ;; new-x))) 182 | 183 | ;; (defun make-contracting-rule (attractor coefficient) 184 | ;; "Creates a function that brings its argument closer to attractor, 185 | ;; contracting the distance by coefficient at each step. Primarily for 186 | ;; use with autobracket." 187 | ;; (assert (< 0 coefficient 1)) 188 | ;; (lambda (x) 189 | ;; (+ (* (- x attractor) coefficient) attractor))) 190 | 191 | ;; (defun root-autobracket (f x negative-rule positive-rule 192 | ;; &key (maximum-iterations 100) 193 | ;; (rootfinder #'root-ridders) 194 | ;; (tolerance #.(expt double-float-epsilon 0.25)) 195 | ;; (epsilon #.(expt double-float-epsilon 0.25))) 196 | ;; "Rootfinder with automatic bracketing. First we evaluate at x, and 197 | ;; check if it is a root. If not, and f(x) is positive, we try to locate 198 | ;; a satisfactory bracket by generating x's using positive-rule. Mutatis 199 | ;; mutandis if f(x) is negative. 200 | 201 | ;; Since the bracket is not known beforehand, you can only specify a 202 | ;; relative tolerance. For the meaning of other parameters, see 203 | ;; rootfinding functions and find-satisfactory-fx." 204 | ;; (assert (<= 0 epsilon)) 205 | ;; (let ((fx (funcall f x))) 206 | ;; (cond 207 | ;; ;; found root 208 | ;; ((<= (abs fx) epsilon) 209 | ;; (values x fx)) 210 | ;; ;; no root, trying to find a negative value for bracketing 211 | ;; ((plusp fx) 212 | ;; (bind (((values y fy) (find-satisfactory-fx x f positive-rule 213 | ;; :satisfactory-p #'minusp 214 | ;; :maximum-iterations maximum-iterations))) 215 | ;; (if (<= (abs fy) epsilon) 216 | ;; (values y fy) 217 | ;; (funcall rootfinder f x y 218 | ;; :tolerance ;(* (absolute-difference x y) 219 | ;; tolerance ;) 220 | ;; :epsilon epsilon)))) 221 | ;; ((minusp fx) 222 | ;; (bind (((values y fy) (find-satisfactory-fx x f negative-rule 223 | ;; :satisfactory-p #'plusp 224 | ;; :maximum-iterations maximum-iterations))) 225 | ;; (if (<= (abs fy) epsilon) 226 | ;; (values y fy) 227 | ;; (funcall rootfinder f x y 228 | ;; :tolerance ;(* (absolute-difference x y) 229 | ;; tolerance ;) 230 | ;; :epsilon epsilon))))))) 231 | 232 | ;;; (root-autobracket #'identity 5 (make-expanding-rule 1 2) 233 | ;;; (make-expanding-rule -1 2)) 234 | -------------------------------------------------------------------------------- /src/test-utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.TEST-UTILITIES -*- 2 | ;;; Copyright (c) 2020-2023 by Symbolics Pte. Ltd. All rights reserved. 3 | ;;; SPDX-License-identifier: MS-PL 4 | 5 | (uiop:define-package #:num-utils.test-utilities 6 | (:use #:cl) 7 | (:import-from #:num-utils.num= 8 | #:num-delta) 9 | (:import-from #:num-utils.arithmetic 10 | #:square) 11 | (:export #:test-results 12 | 13 | ;; struct accessors 14 | #:worst-case ; row at which the worst error occurred 15 | #:min-error ; smallest relative error found 16 | #:max-error ; largest relative error found 17 | #:mean-error ; mean error found 18 | #:test-count ; number of test cases 19 | #:variance0 ; variance of the errors found 20 | #:variance1 ; unbiased variance of the errors found 21 | #:rms ; Root Mean Square, or quadratic mean of the error 22 | 23 | ;; Testing functions 24 | #:test-fn 25 | #:compare-fns 26 | #:compare-vectors)) 27 | (in-package #:num-utils.test-utilities) 28 | 29 | 30 | ;;; Utilities for testing accuracy of mathematical functions 31 | ;;; This does not test the utility functions in num-utils, it is for 32 | ;;; testing the accuracy of the functions in special-functions 33 | 34 | ;;; TEST-FN - Compare a function against known reference values. Used in unit tests. 35 | ;;; COMPARE-FN - Compare a function against a reference implementation, e.g. Cephes 36 | ;;; COMPARE-VECTORS - Compare two vectors of pre-computed values. 37 | 38 | ;;; The examples given assume the special-functions test data has been 39 | ;;; loaded. TEST-UTILITIES was developed in support of that 40 | ;;; library. Note that different versions of the test arrays may have 41 | ;;; the same name, for example NEAR-0. Check the package you are using 42 | ;;; if you duplicate the examples. 43 | 44 | 45 | (defstruct (test-results :conc-name) 46 | "Differences between reference values and computed values" 47 | (worst-case 0 :type integer) ; row at which the worst error occurred 48 | (min-error 0d0 :type double-float) ; smallest relative error found 49 | (max-error 0d0 :type double-float) ; largest relative error found 50 | (mean-error 0d0 :type double-float) ; mean error found 51 | (test-count 0 :type integer) ; number of test cases 52 | (variance0 0d0 :type double-float) ; variance of the errors found 53 | (variance1 0d0 :type double-float) ; unbiased variance of the errors found 54 | (rms 0d0 :type double-float)) ; Root Mean Square, or quadratic mean of the error 55 | 56 | 57 | 58 | ;;; TEST-FUN 59 | 60 | ;;; This is the most commonly used testing function. It takes a vector 61 | ;;; (column of the test data array) of expected values, a function to 62 | ;;; be tested, and parameters to the function. Often the parameters to 63 | ;;; the function are other columns in the same array, as is the case 64 | ;;; with Boost test data. 65 | 66 | ;;; The input function FN is typically a lambda function, taking a row 67 | ;;; index followed by parameters for the function. This makes it easy 68 | ;;; to rearrange the parameters to suit the function being tested. For 69 | ;;; example incomplete-gamma requires keyword arguments, so you can 70 | ;;; provide the keys in the lambda function and the gamma function 71 | ;;; paramaterization values from the FN-PARAM-COLUMNS. 72 | 73 | #| Examples: 74 | To run the Boost Gamma tests using the test values in the 75 | special-functions tests directory: 76 | 77 | (test-fn (select factorials t 1) ; expected values are all rows of the 2nd column (0 based indexing) 78 | #'(lambda (i params) 79 | (specfun:gamma (aref (car params) i))) ; extract the parameter(s) from the param columns 80 | (select factorials t 0)) ; all rows of the 1st column are the parameters to the lambda function 81 | 82 | ;;; Same principal, using a different test data set 83 | (test-fn (select near-1 t 1) 84 | #'(lambda (i params) 85 | (specfun:gamma (aref (car params) i))) 86 | (select near-1 t 0)) 87 | |# 88 | 89 | (defun test-fn (expected-column fn &rest fn-param-columns) 90 | "Test the differences between expected values and the given function" 91 | (loop 92 | with max-delta = 0 and worst-case = 0 and count = (length expected-column) 93 | for i from 0 to (1- count) 94 | for delta = (num-delta (aref expected-column i) (funcall fn i fn-param-columns)) 95 | when (> delta max-delta) :do (progn (setf max-delta delta) 96 | (setf worst-case i)) 97 | minimize delta into min 98 | maximize delta into max 99 | sum delta into sum 100 | sum (square delta) into sum-of-delta-squares 101 | 102 | finally (return (make-test-results :worst-case worst-case 103 | :min-error min 104 | :max-error max 105 | :mean-error (/ sum count) 106 | :test-count count 107 | :variance0 (/ (- sum-of-delta-squares 108 | (/ (square sum) 109 | count)) 110 | count) 111 | :variance1 (/ (- sum-of-delta-squares 112 | (/ (square sum) 113 | count)) 114 | (1- count)) 115 | :rms (sqrt (/ sum-of-delta-squares count)))))) 116 | 117 | 118 | 119 | 120 | ;;; COMPARE-FUNCTIONS 121 | 122 | ;;; Useful if you don't have 'golden' test data and want to test a 123 | ;;; function against a high quality implementation like R, Boost or 124 | ;;; Cephes. 125 | 126 | ;;; FN-PARAMS contain x values and function parametrization values, if 127 | ;;; any. All columns must be the same length 128 | 129 | #| Examples: 130 | The example assumes that special-functions test data for erf is loaded 131 | 132 | (compare-fns #'(lambda (i params) 133 | (specfun:erf (aref (car params) i))) 134 | #'(lambda (i params) 135 | (cephes:erf (aref (car params) i))) 136 | (select erf-data t 0)) 137 | 138 | |# 139 | 140 | (defun compare-fns (fn-1 fn-2 &rest fn-params) 141 | "Compare the values returned by two functions" 142 | (loop 143 | with max-delta = 0 and worst-case = 0 and count = (length (car fn-params)) 144 | for i from 0 to (1- count) 145 | for delta = (num-delta (funcall fn-1 i fn-params) (funcall fn-2 i fn-params)) 146 | when (> delta max-delta) :do (progn (setf max-delta delta) 147 | (setf worst-case i)) 148 | minimize delta into min 149 | maximize delta into max 150 | sum delta into sum 151 | sum (square delta) into sum-of-delta-squares 152 | 153 | finally (return (make-test-results :worst-case worst-case 154 | :min-error min 155 | :max-error max 156 | :mean-error (/ sum count) 157 | :test-count count 158 | :variance0 (/ (- sum-of-delta-squares 159 | (/ (square sum) 160 | count)) 161 | count) 162 | :variance1 (/ (- sum-of-delta-squares 163 | (/ (square sum) 164 | count)) 165 | (1- count)) 166 | :rms (sqrt (/ sum-of-delta-squares count)))))) 167 | 168 | 169 | 170 | ;;; COMPARE-VECTORS 171 | 172 | ;;; REFERENCE-VALUES is a vector containing the 'correct' values of 173 | ;;; the computation. These can be obtained from precomputed tables, 174 | ;;; values from a production system or with a reference function, such 175 | ;;; as Cephes. 176 | ;;; COMPUTED-VALUES is the values from the function under test 177 | ;;; vectors must be of the same size 178 | 179 | (defun compare-vectors (reference-values computed-values) 180 | "Compare two vectors containing the results of previous computations" 181 | (assert (= (length reference-values) 182 | (length computed-values))) 183 | (loop 184 | with max-delta = 0 and worst-case = 0 and count = (length reference-values) 185 | for i from 0 to (1- count) 186 | for delta = (num-delta (aref reference-values i)(aref computed-values i)) 187 | when (> delta max-delta) :do (progn (setf max-delta delta) 188 | (setf worst-case i)) 189 | minimize delta into min 190 | maximize delta into max 191 | sum delta into sum 192 | sum (square delta) into sum-of-delta-squares 193 | 194 | finally (return (make-test-results :worst-case worst-case 195 | :min-error min 196 | :max-error max 197 | :mean-error (/ sum count) 198 | :test-count count 199 | :variance0 (/ (- sum-of-delta-squares 200 | (/ (square sum) 201 | count)) 202 | count) 203 | :variance1 (/ (- sum-of-delta-squares 204 | (/ (square sum) 205 | count)) 206 | (1- count)) 207 | :rms (sqrt (/ sum-of-delta-squares count)))))) 208 | 209 | 210 | -------------------------------------------------------------------------------- /src/utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS.UTILITIES -*- 2 | ;;; Copyright (c) 2019-2023 by Symbolics Pte. Ltd. All rights reserved. 3 | ;;; SPDX-License-identifier: MS-PL 4 | 5 | (uiop:define-package #:num-utils.utilities 6 | (:use #:cl 7 | #:alexandria 8 | #:anaphora 9 | #:let-plus) 10 | (:export #:gethash* 11 | #:splice-when 12 | #:splice-awhen 13 | #:curry* 14 | #:check-types 15 | #:define-with-multiple-bindings 16 | #:within? 17 | #:fixnum? 18 | #:simple-fixnum-vector 19 | #:simple-single-float-vector 20 | #:as-simple-fixnum-vector 21 | #:simple-boolean-vector 22 | #:as-bit-vector 23 | #:as-double-float 24 | #:with-double-floats 25 | #:as-simple-double-float-vector 26 | #:simple-double-float-vector 27 | #:make-vector 28 | #:generate-sequence 29 | #:expanding 30 | #:bic 31 | #:binary-search 32 | #:as-alist 33 | #:as-plist) 34 | (:documentation "A collection of utilities to work with floating point values. Optimised for double-float.")) 35 | (in-package #:num-utils.utilities) 36 | 37 | (defmacro gethash* (key hash-table 38 | &optional (datum "Key not found.") 39 | &rest arguments) 40 | "Like GETHASH, but checking that KEY is present and raising the given error if not." 41 | (with-unique-names (value present?) 42 | `(multiple-value-bind (,value ,present?) (gethash ,key ,hash-table) 43 | (assert ,present? () ,datum ,@arguments) 44 | ,value))) 45 | 46 | (defmacro splice-when (test &body forms) 47 | "Similar to when, but wraps the result in list. 48 | 49 | Example: `(,foo ,@(splice-when add-bar? bar))" 50 | `(when ,test 51 | (list 52 | (progn ,@forms)))) 53 | 54 | (defmacro splice-awhen (test &body forms) 55 | "Similar to splice-when, but binds IT to test." 56 | `(awhen ,test 57 | (list 58 | (progn ,@forms)))) 59 | 60 | (defmacro curry* (function &rest arguments) 61 | "Currying in all variables that are not *. Note that this is a macro, so * should not be quoted, and FUNCTION will be used as is, ie it can be a LAMBDA form." 62 | (let ((arguments (loop for arg in arguments 63 | collect (cond 64 | ((eq arg '*) (gensym "ARG")) 65 | ((keywordp arg) (list arg)) 66 | (t (list (gensym "VAR") arg)))))) 67 | `(let ,(loop for arg in arguments 68 | when (and (consp arg) (cdr arg)) 69 | collect arg) 70 | (lambda ,(loop for arg in arguments 71 | unless (consp arg) 72 | collect arg) 73 | (,function ,@(loop for arg in arguments 74 | collect (if (consp arg) 75 | (car arg) 76 | arg))))))) 77 | 78 | (defmacro check-types ((&rest arguments) type) 79 | "CHECK-TYPE for multiple places of the same type. Each argument is either a place, or a list of places and a type-string. 80 | 81 | Example: (check-types (a b) double-float)" 82 | `(progn 83 | ,@(loop 84 | for argument :in arguments 85 | collecting (if (atom argument) 86 | `(check-type ,argument ,type) 87 | (let+ (((place type-string) argument)) 88 | `(check-type ,place ,type ,type-string)))))) 89 | 90 | (defmacro define-with-multiple-bindings 91 | (macro &key 92 | (plural (intern (format nil "~aS" macro))) 93 | (docstring (format nil "Multiple binding version of ~(~a~)." macro))) 94 | "Define a version of MACRO with multiple arguments, given as a list. Application of MACRO will be nested. The new name is the plural of the old one (generated using format by default)." 95 | `(defmacro ,plural (bindings &body body) 96 | ,docstring 97 | (if bindings 98 | `(,',macro ,(car bindings) 99 | (,',plural ,(cdr bindings) 100 | ,@body)) 101 | `(progn ,@body)))) 102 | 103 | (declaim (inline within?)) 104 | (defun within? (left value right) 105 | "Return non-nil iff value is in [left,right)." 106 | (and (<= left value) (< value right))) 107 | 108 | 109 | ;;; fixnum 110 | (declaim (inline fixnum?)) 111 | (defun fixnum? (object) 112 | "Check of type of OBJECT is fixnum." 113 | (typep object 'fixnum)) 114 | 115 | (deftype simple-fixnum-vector () 116 | "Simple vector of fixnum elements." 117 | '(simple-array fixnum (*))) 118 | 119 | (defun as-simple-fixnum-vector (sequence &optional copy?) 120 | "Convert SEQUENCE to a SIMPLE-FIXNUM-VECTOR. When COPY?, make sure that they don't share structure." 121 | (if (and (typep sequence 'simple-fixnum-vector) copy?) 122 | (copy-seq sequence) 123 | (coerce sequence 'simple-fixnum-vector))) 124 | 125 | 126 | ;;; boolean 127 | (declaim (inline boolean?)) 128 | (defun boolean? (object) 129 | "Check type of OBJECT is BOOLEAN." 130 | (typep object 'boolean)) 131 | 132 | (defun boolean-sequence-p (x) 133 | (every #'boolean? x)) 134 | 135 | (deftype simple-boolean-vector (&optional (length '*)) 136 | "Vector of BOOLEAN elements." 137 | `(and (simple-array * (,length)) 138 | (satisfies boolean-sequence-p))) 139 | 140 | (defun as-bit-vector (v) 141 | "Return a bit vector where each non-nil element of V is mapped to 1 and each NIL element is mapped to 0" 142 | (map 'simple-bit-vector #'(lambda (x) (if x 1 0)) v)) 143 | 144 | 145 | ;;; double-float 146 | (defun as-double-float (x) 147 | "Convert argument to DOUBLE-FLOAT." 148 | (coerce x 'double-float)) 149 | 150 | (defmacro with-double-floats (bindings &body body) 151 | "For each binding = (variable value), coerce VALUE to DOUBLE-FLOAT and bind it to VARIABLE for BODY. When VALUE is omitted, VARIABLE is used instead. When BINDING is an atom, it is used for both the value and the variable. 152 | 153 | Example: 154 | (with-double-floats (a 155 | (b) 156 | (c 1)) 157 | ...)" 158 | `(let ,(mapcar (lambda (binding) 159 | (let+ (((variable &optional (value variable)) 160 | (ensure-list binding))) 161 | `(,variable (as-double-float ,value)))) 162 | bindings) 163 | ,@body)) 164 | 165 | (deftype simple-double-float-vector (&optional (length '*)) 166 | "Simple vector of double-float elements." 167 | `(simple-array double-float (,length))) 168 | 169 | (deftype simple-single-float-vector (&optional (length '*)) 170 | "Simple vector of single-float elements." 171 | `(simple-array single-float (,length))) 172 | 173 | (defun as-simple-double-float-vector (sequence &optional copy?) 174 | "Convert SEQUENCE to a SIMPLE-DOUBLE-FLOAT-VECTOR. When COPY?, make sure they don't share structure." 175 | (assert (every #'realp sequence) (sequence) "SEQUENCE ~S contains non-numeric values." sequence) 176 | (if (and (typep sequence 'simple-double-float-vector) copy?) 177 | (copy-seq sequence) 178 | (map 'simple-double-float-vector 'as-double-float sequence))) 179 | 180 | 181 | 182 | (defun generate-sequence (result-type size function) 183 | "Like MAKE-SEQUENCE, but using a function to fill the result. 184 | 185 | Example to create a sequence of random numbers between 0-1 from the uniform distribution: 186 | (generate-sequence '(vector double-float) 100 (lambda () (random 1.0))). 187 | Essentially the initial values are ignored when using this function. 188 | See also: aops:generate" 189 | (map-into (make-sequence result-type size) function)) 190 | 191 | (defmacro expanding (&body body) 192 | "Expand BODY. Useful for generating code programmatically." 193 | (with-gensyms (local-macro) 194 | `(macrolet ((,local-macro () 195 | ,@body)) 196 | (,local-macro)))) 197 | 198 | (defun bic (a b) 199 | "Biconditional. Returns A <=> B." 200 | (if a b (not b))) 201 | 202 | (defun binary-search (sorted-reals value) 203 | "Return INDEX such that 204 | 205 | (WITHIN? (AREF SORTED-REALS INDEX) VALUE (AREF SORTED-REALS (1+ INDEX)). 206 | 207 | SORTED-REALS is assumed to be reals sorted in ascending order (not checked, if this does not hold the result may be nonsensical, though the algorithm will terminate). 208 | 209 | If value is below (or above) the first (last) break, NIL (T) is returned." 210 | (let+ ((left 0) 211 | (right (1- (length sorted-reals))) 212 | ((&flet sr (index) (aref sorted-reals index)))) 213 | (cond 214 | ((< value (sr left)) nil) 215 | ((<= (sr right) value) t) 216 | (t (loop 217 | (when (= (1+ left) right) 218 | (return left)) 219 | (let ((middle (floor (+ left right) 2))) 220 | (if (< value (sr middle)) 221 | (setf right middle) 222 | (setf left middle)))))))) 223 | 224 | (defgeneric as-alist (object) 225 | (:documentation "Return OBJECT as an ALIST. Semantics depends on OBJECT.")) 226 | 227 | (defgeneric as-plist (object) 228 | (:documentation "Return OBJECT as a PLIST. Semantics depends on OBJECT. The default method uses AS-ALIST.") 229 | (:method (object) 230 | (alist-plist (as-alist object)))) 231 | 232 | (defun make-vector (element-type &rest initial-contents) 233 | (make-array (length initial-contents) :element-type element-type 234 | :initial-contents initial-contents)) 235 | 236 | (define-compiler-macro make-vector (element-type &rest initial-contents) 237 | `(let ((vec (make-array ,(length initial-contents) 238 | :element-type ,element-type))) 239 | ,@(let ((i -1)) 240 | (mapcar (lambda (form) 241 | `(setf (aref vec ,(incf i)) ,form)) 242 | initial-contents)) 243 | vec)) 244 | 245 | -------------------------------------------------------------------------------- /tests/arithmetic.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | (def-suite arithmetic 8 | :description "Test arithmetic functions" 9 | :in all-tests) 10 | (in-suite arithmetic) 11 | 12 | (test arithmetic-functions 13 | (is (same-sign-p 1 2 3)) 14 | (not (same-sign-p 1 -2 3)) 15 | (is (= 4 (square 2))) 16 | (is (= 4.0 (absolute-square 2.0))) 17 | (is (= 25 (absolute-square #C(3 4)))) 18 | (is (= 2 (abs-diff 3 5))) 19 | (is (= 2 (abs-diff -3 -5))) 20 | (is (num= 2 (log10 100))) 21 | (is (num= 8 (log2 256))) 22 | (is (= 1/5 (1c 4/5))) 23 | (is (divides? 8 2)) 24 | (not (divides? 8 3)) 25 | (is (= 2 (as-integer 2.0))) 26 | (is (= 5 (seq-max #(0 1 2 3 4 5)))) 27 | (is (= 5 (seq-max '(0 1 2 3 4 5)))) 28 | (is (= 0 (seq-min #(0 1 2 3 4 5)))) 29 | (is (= 0 (seq-min '(0 1 2 3 4 5)))) 30 | (signals error (as-integer 2.5))) 31 | 32 | (test arithmetic-sequences 33 | (is (equalp #(2 3 4) (numseq 2 4))) 34 | (is (equalp #(2 4 6 8) (numseq 2 nil :length 4 :by 2))) 35 | (is (equalp #(0 1 2 3) (ivec 4))) 36 | (is (equalp #(1 2 3) (ivec 1 4))) 37 | (is (equalp #(1 3) (ivec 1 4 2))) 38 | (signals error #(1 3) (ivec 4 1 1 t))) 39 | 40 | (test arithmetic-summaries 41 | (let ((v #(2 3 4))) 42 | (is (= 9 (sum v))) 43 | (is (= 24 (product v))) 44 | (is (equalp #(2 5 9) (cumulative-sum v))) 45 | (is (equalp #(2 6 24) (cumulative-product v))) 46 | (is (= 0 (sum #()))) 47 | (is (= 1 (product #()))) 48 | (is (equalp #() (cumulative-sum #()))) 49 | (is (equalp #() (cumulative-product #()))))) 50 | 51 | (test normalize-probabilities 52 | (let* ((a (vector 1 2 7)) 53 | (a-copy (copy-seq a))) 54 | (is (equalp #(1/10 2/10 7/10) (normalize-probabilities a))) 55 | (is (equalp a a-copy)) ; not modified 56 | (is (equalp #(0.1d0 0.2d0 0.7d0) 57 | (normalize-probabilities a :element-type 'double-float))) 58 | (is (equalp a a-copy)) ; not modified 59 | (signals error (normalize-probabilities #(1 -1))) 60 | (let ((normalized #(0.1d0 0.2d0 0.7d0))) 61 | (is (equalp normalized 62 | (normalize-probabilities a 63 | :element-type 'double-float 64 | :result nil))) 65 | (is (equalp a normalized)) 66 | (not (equalp a a-copy))))) 67 | 68 | (test arithmetic-rounding 69 | (is (equalp '(25 2) (multiple-value-list (floor* 27 5)))) 70 | (is (equalp '(26 1) (multiple-value-list (floor* 27 5 1)))) 71 | (is (equalp '(30 -3) (multiple-value-list (ceiling* 27 5)))) 72 | (is (equalp '(31 -4) (multiple-value-list (ceiling* 27 5 1)))) 73 | (is (equalp '(25 2) (multiple-value-list (round* 27 5)))) 74 | (is (equalp '(29 -2) (multiple-value-list (round* 27 5 -1)))) 75 | (is (equalp '(-25 -2) (multiple-value-list (truncate* -27 5)))) 76 | (is (equalp '(-24 -3) (multiple-value-list (truncate* -27 5 1))))) 77 | 78 | -------------------------------------------------------------------------------- /tests/chebyshev.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | (def-suite chebyshev 8 | :description "Test chebyshev functions" 9 | :in all-tests) 10 | (in-suite chebyshev) 11 | 12 | (defun maximum-on-grid (f interval &optional (n-grid 1000)) 13 | "Maximum of F on a grid of N-GRID equidistand points in INTERVAL." 14 | (loop for index below n-grid 15 | maximizing (funcall f 16 | (interval-midpoint interval 17 | (/ index (1- n-grid)))))) 18 | 19 | (defun approximation-error (f f-approx interval &optional (n-grid 1000)) 20 | "Approximation error, using MAXIMUM-ON-GRID." 21 | (maximum-on-grid (lambda (x) 22 | (abs-diff (funcall f x) (funcall f-approx x))) 23 | interval n-grid)) 24 | 25 | (defun test-chebyshev-approximate (f interval n-polynomials test-interval 26 | &rest rest) 27 | (let ((f-approx (apply #'chebyshev-approximate f interval n-polynomials rest))) 28 | (approximation-error f f-approx test-interval))) 29 | 30 | (test chebyshev-open-inf 31 | (is (<= (test-chebyshev-approximate (lambda (x) (/ x (+ 4 x))) 32 | (interval 2 :plusinf) 15 33 | (interval 2 102)) 34 | 1e-5)) 35 | (is (<= (test-chebyshev-approximate (lambda (x) (exp (- x))) 36 | (interval 0 :plusinf) 15 37 | (interval 0 10) 38 | :n-points 30) 39 | 1e-4))) 40 | 41 | (test chebyshev-finite-interval 42 | (is (<= (test-chebyshev-approximate (lambda (x) (/ (1+ (expt x 2)))) 43 | (interval -3d0 2d0) 20 44 | (interval -1.5d0 1d0)) 45 | 1e-3))) 46 | -------------------------------------------------------------------------------- /tests/elementwise.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | (def-suite elementwise 8 | :description "Test elementwise functions" 9 | :in all-tests) 10 | (in-suite elementwise) 11 | 12 | (test elementwise-float-contagion 13 | (flet ((compare (type &rest objects) 14 | (type= (apply #'num-utils.elementwise::elementwise-float-contagion 15 | objects) type))) 16 | (is (compare 'double-float 1d0) 0) 17 | (is (compare 'real 0 1)))) 18 | 19 | (test e-operations-tests 20 | (let+ (((&flet arr (dimensions element-type &rest elements) 21 | (aprog1 (make-array dimensions :element-type element-type) 22 | (assert (length= elements (array-total-size it))) 23 | (loop for index from 0 24 | for element in elements 25 | do (setf (row-major-aref it index) 26 | (coerce element element-type)))))) 27 | (a (arr '(2 3) 'double-float 28 | 1 2 3 29 | 4 5 6)) 30 | (b (arr '(2 3) 'single-float 31 | 2 3 5 32 | 7 11 13))) 33 | (is (equalp (e+ a b) (arr '(2 3) 'double-float 34 | 3 5 8 35 | 11 16 19))) 36 | (is (equalp (e* a 2s0) (arr '(2 3) 'double-float 37 | 2 4 6 38 | 8 10 12))) 39 | (is (equalp (e+ a 2 b) (e+ (e+ a b) 2))) 40 | (is (equalp (e+ a a) (e* a 2))) 41 | (signals error (e/ a 0)) ; division by 0 42 | (signals error (e+ a ; dimension incompatibility 43 | (arr '(1 1) 'double-float 2))) 44 | (is (equalp (e+ a) (e+ a 0))) 45 | (is (equalp (e* a) (e* a 1))) 46 | (is (equalp (e- a) (e- 0d0 a))) 47 | (is (equalp (e/ a) (e/ 1d0 a))) 48 | (is (num= #(1.0) (elog #(10) 10))) 49 | (is (num= a (eexp (elog a)))))) 50 | 51 | ;;; Commented out by Papp. Should these be in array-operations? 52 | ;; (deftest (elementwise-tests) 53 | ;; stack-tests 54 | ;; (let ((a (array* '(2 3) t 55 | ;; 1 2 3 56 | ;; 4 5 6)) 57 | ;; (b (array* '(2 2) t 58 | ;; 3 5 59 | ;; 7 9)) 60 | ;; (*lift-equality-test* #'equalp)) 61 | ;; (assert-equalp (stack 'double-float :h a b) 62 | ;; (array* '(2 5) 'double-float 63 | ;; 1 2 3 3 5 64 | ;; 4 5 6 7 9)) 65 | ;; (assert-equalp (stack t :v (transpose a) b) 66 | ;; #2A((1 4) 67 | ;; (2 5) 68 | ;; (3 6) 69 | ;; (3 5) 70 | ;; (7 9))) 71 | ;; (assert-equalp (stack 'fixnum :v a #(7 8 9) 10) 72 | ;; (array* '(4 3) 'fixnum 73 | ;; 1 2 3 74 | ;; 4 5 6 75 | ;; 7 8 9 76 | ;; 10 10 10)) 77 | ;; (assert-equalp (stack t :h b #(1 2) b 9 b) 78 | ;; (array* '(2 8) t 79 | ;; 3 5 1 3 5 9 3 5 80 | ;; 7 9 2 7 9 9 7 9)) 81 | ;; (assert-equalp (stack t :h 82 | ;; (vector* 'double-float 1d0 2d0) 83 | ;; (vector* 'double-float 3d0 4d0)) 84 | ;; (array* '(2 2) 'double-float 85 | ;; 1 3 86 | ;; 2 4)) 87 | ;; (assert-equalp (stack 'double-float :h 1.0d0 #()) ; empty array 88 | ;; (array* '(0 2) 'double-float)))) 89 | 90 | ;; (deftest (elementwise-tests) 91 | ;; concat-test 92 | ;; (assert-equalp (concat t #(1 2 3) #(4 5 6) (list 7) '(8 9 10)) 93 | ;; (numseq 1 10 :type t) :test #'equalp)) 94 | -------------------------------------------------------------------------------- /tests/extended-real.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | (def-suite extended-real 8 | :description "Test extended real functions" 9 | :in all-tests) 10 | (in-suite extended-real) 11 | 12 | ;;; helper functions for defining tests 13 | 14 | (defun assert-relation (relation &rest argument-lists) 15 | "Assert RELATION called with each set of arguments." 16 | (loop for a in argument-lists 17 | do (is (apply relation a)))) 18 | 19 | (defun assert-not-relation (relation &rest argument-lists) 20 | "Assert that RELATION does not hold, called with each set of arguments." 21 | (loop for a in argument-lists 22 | do (not (apply relation a)))) 23 | 24 | (defun assert-paired-relation (relation1 relation2 &rest argument-lists) 25 | (apply #'assert-relation relation1 argument-lists) 26 | (apply #'assert-relation relation2 (mapcar #'reverse argument-lists))) 27 | 28 | (defun assert-not-paired-relation (relation1 relation2 &rest argument-lists) 29 | (apply #'assert-not-relation relation1 argument-lists) 30 | (apply #'assert-not-relation relation2 (mapcar #'reverse argument-lists))) 31 | 32 | (defun assert-relation-corner-cases (&rest relations) 33 | (loop for r in relations 34 | do (is (funcall r 1)) 35 | (is (funcall r :plusinf)) 36 | (is (funcall r :minusinf)) 37 | (signals error (funcall r)))) 38 | 39 | (test relation-corner-cases-test 40 | (assert-relation-corner-cases #'xreal:= #'xreal:< #'xreal:> #'xreal:>= #'xreal:<=)) 41 | 42 | (test strict-inequalities-test 43 | (assert-paired-relation #'xreal:< #'xreal:> 44 | ;; < pairs 45 | '(1 2) 46 | '(1 :plusinf) 47 | '(:minusinf :plusinf) 48 | '(:minusinf 1) 49 | ;; < sequences 50 | '(1 2 3) 51 | '(1 2 :plusinf) 52 | '(:minusinf 1 4 :plusinf)) 53 | (assert-not-paired-relation #'xreal:< #'xreal:> 54 | ;; not < pairs 55 | '(1 1) 56 | '(2 1) 57 | '(:plusinf :plusinf) 58 | '(:plusinf 1) 59 | '(:minusinf :minusinf) 60 | '(:plusinf :minusinf) 61 | '(1 :minusinf) 62 | ;; not < sequences 63 | '(1 2 2) 64 | '(1 3 2) 65 | '(1 :plusinf 2) 66 | '(1 :plusinf :plusinf))) 67 | 68 | (test inequalities-test 69 | (assert-paired-relation #'xreal:<= #'xreal:>= 70 | ;; <= pairs 71 | '(1 1) 72 | '(1 2) 73 | '(1 :plusinf) 74 | '(:plusinf :plusinf) 75 | '(:minusinf :plusinf) 76 | '(:minusinf :minusinf) 77 | '(:minusinf 1) 78 | ;; < sequences 79 | '(1 2 2) 80 | '(1 2 3) 81 | '(1 2 :plusinf) 82 | '(1 :plusinf :plusinf) 83 | '(:minusinf 1 4 :plusinf)) 84 | (assert-not-paired-relation #'xreal:<= #'xreal:>= 85 | ;; not < pairs 86 | '(2 1) 87 | '(:plusinf 1) 88 | '(:plusinf :minusinf) 89 | '(1 :minusinf) 90 | ;; not <=/>= sequences 91 | '(1 3 2) 92 | '(1 :plusinf 2))) 93 | 94 | (test equality-test 95 | (assert-relation #'xreal:= 96 | ;; = pairs 97 | '(1 1) 98 | '(:plusinf :plusinf) 99 | '(:minusinf :minusinf) 100 | ;; = sequences 101 | '(2 2 2) 102 | '(:plusinf :plusinf :plusinf) 103 | '(:minusinf :minusinf :minusinf)) 104 | (assert-not-relation #'xreal:= 105 | ;; not = pairs 106 | '(1 2) 107 | '(2 1) 108 | '(1 :plusinf) 109 | '(:plusinf 1) 110 | '(1 :minusinf) 111 | '(:minusinf 1) 112 | ;; not = sequences 113 | '(1 2 2) 114 | '(2 2 1) 115 | '(:plusinf :plusinf 9) 116 | '(:plusinf :minusinf))) 117 | -------------------------------------------------------------------------------- /tests/interval.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | (def-suite interval 8 | :description "Test interval functions" 9 | :in all-tests) 10 | (in-suite interval) 11 | 12 | (test interval 13 | (let ((a (interval 1 2))) 14 | (is (num= 1 (interval-length a))) 15 | (is (num= 1.25 (interval-midpoint a 0.25))) 16 | (is (num= (interval 1.25 1.8) (shrink-interval a 0.25 0.2))) 17 | (is (in-interval? a 1.5)) 18 | (is (in-interval? a 1)) 19 | (is (in-interval? a 2)) 20 | (not (in-interval? a 0.9)) 21 | (not (in-interval? a 2.1)) 22 | (signals error (interval 2 1)))) 23 | 24 | (test interval-hull 25 | (let ((a (interval 1 2))) 26 | (is (num= nil (interval-hull nil))) 27 | (is (num= a (interval-hull a))) 28 | (is (num= a (interval-hull '(1 1.5 2)))) 29 | (is (num= a (interval-hull #(1 1.5 2)))) 30 | (is (num= a (interval-hull #2A((1) (1.5) (2))))) 31 | (is (num= (interval -1 3) 32 | (interval-hull (list (interval 0 2) -1 #(3) '(2.5))))) 33 | (signals error (interval-hull #C(1 2))))) 34 | 35 | (test split-interval 36 | (let ((a (interval 10 20))) 37 | (is (num= (vector (interval 10 13) (interval 13 14) (interval 14 20)) 38 | (split-interval a (list (spacer 1) (relative 0.1) (spacer 2))))) 39 | (is (num= (vector (interval 10 16) (interval 16 20)) 40 | (split-interval a (list (spacer) 4)))) 41 | (signals error (split-interval a (list 9))) 42 | (signals error (split-interval a (list 6 7 (spacer)))))) 43 | 44 | (test extendf-interval 45 | (let+ ((counter -1) 46 | (a (make-array 2 :initial-contents (list nil (interval 1 2))))) 47 | (extendf-interval (aref a (incf counter)) 3) 48 | (extendf-interval (aref a (incf counter)) 3) 49 | (is (num= (vector (interval 3 3) (interval 1 3)) a)) 50 | (is (num= 1 counter)))) 51 | 52 | (test grid-in 53 | (is (num= #(0.0 0.5 1.0) (grid-in (interval 0.0 1.0) 3))) 54 | (is (num= #(0 2 4) (grid-in (interval 0 4) 3)))) 55 | 56 | (test subintervals-in 57 | (let ((expected (vector (interval 0 1 :open-left? nil :open-right? t) 58 | (interval 1 2 :open-left? nil :open-right? t) 59 | (interval 2 3 :open-left? nil :open-right? nil)))) 60 | (is (num= (subintervals-in (interval 0 3) 3) 61 | expected)))) 62 | 63 | (test plusminus-interval 64 | (is (num= (interval 0.5 1.5) (plusminus-interval 1 0.5)))) 65 | -------------------------------------------------------------------------------- /tests/main.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2021 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | (def-suite all-tests 6 | :description "The master suite of all NUMERIC-UTILITIES tests") 7 | 8 | (in-suite all-tests) 9 | 10 | #+genera (setf *print-array* t) 11 | 12 | ;;; These two came from special-functions when I moved log-exp 13 | ;;; here. Might be worth consolidating at some point. 14 | 15 | (defparameter *report-epsilon* t "Print key statistics in terms of machine epsilon") 16 | 17 | (defun print-test-summary (result &key (report-epsilon *report-epsilon*)) 18 | "Print summary of results. 19 | Include some values in epsilon if report-epsilon is true. This is useful when comparing to other implementations" 20 | (write result) 21 | (when report-epsilon 22 | (format t "~% Key stats in terms of epsilon:~% Max = ~,2Eε (Mean = ~,2Eε)~%" 23 | (/ (max-error result) double-float-epsilon) 24 | (/ (mean-error result) double-float-epsilon)))) 25 | 26 | (defun eps (x) 27 | "Return a multiple of epsilon" 28 | (* x double-float-epsilon)) 29 | 30 | (defun test-nu () 31 | (run! 'all-tests)) 32 | 33 | -------------------------------------------------------------------------------- /tests/matrix-shorthand.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | (def-suite matrix-shorthand 8 | :description "Tests matrix-shorthand functions" 9 | :in all-tests) 10 | (in-suite matrix-shorthand) 11 | 12 | (test lower-triangular-shorthand-test 13 | (let ((matrix #2A((1 2) 14 | (3 4))) 15 | (lower-triangular-mx (lower-triangular-mx t 16 | (1) 17 | (3 4)))) 18 | (is (num= (lower-triangular-matrix matrix) lower-triangular-mx)) 19 | (is (num= lower-triangular-mx (lower-triangular-mx t 20 | (1 9) ; 9 should be ignored 21 | (3 4)))) 22 | (is (num= (lower-triangular-mx t 23 | (1 2 3) 24 | (3 4 5)) 25 | (lower-triangular-mx t 26 | (1 2 17) 27 | (3 4 5)))) 28 | (is (num= (lower-triangular-mx t 29 | (1 2) 30 | (3 4) 31 | (5 6)) 32 | (lower-triangular-mx t 33 | (1 19) 34 | (3 4) 35 | (5 6)))))) 36 | 37 | (test upper-triangular-shorthand-test 38 | (let ((matrix #2A((1 2) 39 | (3 4))) 40 | (upper-triangular-mx (upper-triangular-mx t 41 | (1 2) 42 | (3 4)))) 43 | (is (num= (upper-triangular-matrix matrix) upper-triangular-mx)) 44 | (is (num= upper-triangular-mx (upper-triangular-mx t 45 | (1 2) 46 | (9 4)))) ; 9 should be ignored 47 | (is (num= (upper-triangular-mx t 48 | (1 2 3) 49 | (3 4 5)) 50 | (upper-triangular-mx t 51 | (1 2 3) 52 | (19 4 5)))) 53 | (is (num= (upper-triangular-mx t 54 | (1 2) 55 | (3 4) 56 | (5 6)) 57 | (upper-triangular-mx t 58 | (1 2) 59 | (3 4) 60 | (19 6)))))) 61 | 62 | (test hermitian-shorthand-test 63 | (let ((matrix #2A((1 2) 64 | (3 4))) 65 | (hermitian-mx (hermitian-mx t 66 | (1) 67 | (3 4)))) 68 | (is (num= hermitian-mx (hermitian-matrix matrix))) 69 | (is (num= hermitian-mx (hermitian-mx t 70 | (1 9) ; 9 should be ignored 71 | (3 4)))) 72 | (signals error (hermitian-mx t 73 | (1 2 3) 74 | (3 4 5))))) 75 | 76 | (test diagonal-shorthand-test 77 | (is (num= (diagonal-mx t 1 2 3) (diagonal-matrix #(1 2 3))))) 78 | 79 | (test vec-shorthand-test 80 | (is (num= (vec t 1 2 3) #(1 2 3)))) 81 | -------------------------------------------------------------------------------- /tests/matrix.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019, 2023 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | (def-suite matrix 8 | :description "Test matrix functions" 9 | :in all-tests) 10 | (in-suite matrix) 11 | 12 | (test wrapped-univariate-operation 13 | (is (num= (e- (upper-triangular-mx t 2)) (upper-triangular-mx t -2))) 14 | (is (num= (e/ (upper-triangular-mx t 2)) (upper-triangular-mx t 0.5))) 15 | (is (num= (e+ (upper-triangular-mx t 2)) (upper-triangular-mx t 2)))) 16 | 17 | (defun do-matrix-convert-ops (test converts &key (ops (list #'e+ #'e- #'e*))) 18 | "Funcall TEST with CONVERT and each operation in OPs." 19 | (mapc (lambda (convert) 20 | (mapc (curry #'funcall test convert) ops)) 21 | converts)) 22 | 23 | (defun assert-distributive-convert-op (a b convert op) 24 | "Check that OP distributes over CONVERT." 25 | (is (num= (funcall convert (funcall op a b)) 26 | (funcall op (funcall convert a) (funcall convert b))))) 27 | 28 | #| 20191001 (SN) Added during debugging process 29 | (defun assert-associative-convert-op (a b convert op) 30 | "Check that OP is associative over CONVERT." 31 | ;; (declare (ignore a b convert op)) 32 | ;; (skip "op a b = op b a. Bug somewhere.") 33 | ;; (skip "op b a = op a b. Bug somewhere.") 34 | ;; (let* ((x (funcall op a b)) 35 | ;; (y (funcall op (funcall convert a) b))) 36 | ;; (is (num= x y) 37 | ;; "Expected x, ~A, to be equal to y, ~A.~%funcall op a b returns: ~A~%funcall op funcall convert a returns: ~A~%" 38 | ;; x 39 | ;; y 40 | ;; (funcall op a b) 41 | ;; (funcall op (funcall convert a) b) 42 | ;; ))) 43 | (format t "~%num= returns ~A~%" (num= (funcall op a b) 44 | (funcall op (funcall convert a) b))) 45 | (is (num= (funcall op a b) 46 | (funcall op (funcall convert a) b));) 47 | "Expected ~A to be equal to ~A" (funcall op a b) (funcall op (funcall convert a) b)) 48 | (format t "~%num= returns ~A~%" (num= (funcall op a b) 49 | (funcall op (funcall convert a) b))) 50 | (is (num= (funcall op a b) 51 | (funcall op a (funcall convert b))) 52 | "Expected ~A to be equal to ~A" (funcall op a b) (funcall op a (funcall convert b)))) 53 | |# 54 | 55 | (test wrapped-bivariate-operation 56 | (do-matrix-convert-ops (curry #'assert-distributive-convert-op 57 | (mx t 58 | (1 2) 59 | (3 4)) 60 | (mx t 61 | (5 7) 62 | (11 13))) 63 | (list #'hermitian-matrix 64 | #'lower-triangular-matrix 65 | #'upper-triangular-matrix))) 66 | #+ignore 67 | (test wrapped-bivariate-to-array 68 | (let+ ((a (mx t 69 | (1 2) 70 | (3 4))) 71 | (b (mx t 72 | (5 7) 73 | (11 13)))) 74 | (do-matrix-convert-ops (curry #'assert-associative-convert-op a b) 75 | (list #'hermitian-matrix 76 | #'lower-triangular-matrix 77 | #'upper-triangular-matrix)))) 78 | 79 | ;;; Transliteration of clunit deftest 80 | ;;; Commented out reason-args because they make the failure appear to be a false positive 81 | (test wrapped-bivariate-to-array 82 | (let+ ((a (mx t 83 | (1 2) 84 | (3 4))) 85 | (b (mx t 86 | (5 7) 87 | (11 13)))) 88 | (do-matrix-convert-ops (lambda (convert op) 89 | (is (num= (funcall op a b) 90 | (funcall op (funcall convert a) b))) 91 | ;; "Expected ~A but received ~A" (funcall op a b) (funcall op (funcall convert a) b)) 92 | (is (num= (funcall op a b) 93 | (funcall op a (funcall convert b))))) 94 | ;; "Expected ~A but received ~A" (funcall op a b) (funcall op a (funcall convert b)))) 95 | (list #'hermitian-matrix 96 | #'lower-triangular-matrix 97 | #'upper-triangular-matrix)))) 98 | 99 | #| Original clunit test from Papp. Works in clunit 100 | (deftest wrapped-bivariate-to-array (matrix-suite) 101 | (let+ ((a (mx t 102 | (1 2) 103 | (3 4))) 104 | (b (mx t 105 | (5 7) 106 | (11 13)))) 107 | (do-matrix-convert-ops (lambda (convert op) 108 | (assert-equality #'num= (funcall op a b) 109 | (funcall op (funcall convert a) b)) 110 | (assert-equality #'num= (funcall op a b) 111 | (funcall op a (funcall convert b)))) 112 | (list #'hermitian-matrix 113 | #'lower-triangular-matrix 114 | #'upper-triangular-matrix)))) 115 | |# 116 | (test diagonal-test 117 | (do-matrix-convert-ops (curry #'assert-distributive-convert-op 118 | (vec t 1 2 3 4) 119 | (vec t 5 7 11 13)) 120 | (list #'diagonal-matrix))) 121 | 122 | (test wrapped-matrix-slice 123 | (let+ ((mx (mx t 124 | (1 2 3) 125 | (4 5 6) 126 | (7 8 9))) 127 | ((¯olet assert-slice (type) 128 | (check-type type symbol) 129 | `(let* ((wrapped (,type mx)) 130 | (slice (range 0 2)) 131 | (sliced (select wrapped slice))) 132 | (is (eq ',type (type-of sliced))) 133 | (is (num= sliced (,type (select mx slice slice)))))))) 134 | (assert-slice upper-triangular-matrix) 135 | (assert-slice lower-triangular-matrix) 136 | (assert-slice hermitian-matrix))) 137 | 138 | 139 | 140 | -------------------------------------------------------------------------------- /tests/num=.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;;; Copyright (c) 2019 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | (def-suite num= 8 | :description "Tests num= functions" 9 | :in all-tests) 10 | (in-suite num=) 11 | 12 | (test num=-number-test 13 | (let ((*num=-tolerance* 1e-3)) 14 | (is (num= 1 1)) 15 | (is (num= 1 1.0)) 16 | (is (num= 1 1.001)) 17 | (not (num= 1 2)) 18 | (not (num= 1 1.01)))) 19 | 20 | (test num=-list-test 21 | (let ((*num=-tolerance* 1e-3)) 22 | (is (num= nil nil)) 23 | (is (num= '(1) '(1.001))) 24 | (is (num= '(1 2) '(1.001 1.999))) 25 | (not (num= '(0 1) '(0 1.02))) 26 | (not (num= nil '(1))))) 27 | 28 | (test num=-array-test 29 | (let* ((*num=-tolerance* 1e-3) 30 | (a #(0 1 2)) 31 | (b #2A((0 1) 32 | (2 3)))) 33 | (is (num= a a)) 34 | (is (num= a #(0 1.001 2))) 35 | (is (num= a #(0 1.001 2.001))) 36 | (is (num= b b)) 37 | (is (num= b #2A((0 1) 38 | (2.001 3)))) 39 | (not (num= a b)) 40 | (not (num= a #(0 1))) 41 | (not (num= a #(0 1.01 2))) 42 | (not (num= b #2A((0 1)))) 43 | (not (num= b #2A((0 1.01) 44 | (2 3)))))) 45 | 46 | (defstruct num=-test-struct 47 | "Structure for testing DEFINE-STRUCTURE-num=." 48 | a b) 49 | 50 | (define-structure-num= num=-test-struct a b) 51 | 52 | (test num=-structure-test 53 | (let ((*num=-tolerance* 1e-3) 54 | (a (make-num=-test-struct :a 0 :b 1)) 55 | (b (make-num=-test-struct :a "string" :b nil))) 56 | (is (num= a a)) 57 | (is (num= a (make-num=-test-struct :a 0 :b 1))) 58 | (is (num= a (make-num=-test-struct :a 0 :b 1.001))) 59 | (not (num= a (make-num=-test-struct :a 0 :b 1.01))) 60 | (is (num= b b)) 61 | (not (num= a b)))) 62 | -------------------------------------------------------------------------------- /tests/old/arithmetic.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (deftestsuite arithmetic-tests (cl-num-utils-tests) 6 | () 7 | (:equality-test #'equalp)) 8 | 9 | (addtest (arithmetic-tests) 10 | ivec-test 11 | (let ((*lift-equality-test* #'equalp)) 12 | (ensure-same (ivec 3) #(0 1 2)) 13 | (ensure-same (ivec -2) #(0 -1)) 14 | (ensure-same (ivec 2 5) #(2 3 4)) 15 | (ensure-same (ivec 0) #()) 16 | (ensure-same (ivec 2 6 2) #(2 4)) 17 | (ensure-same (ivec 6 2 2) #(6 4)) 18 | (ensure-same (ivec -2 -9 3) #(-2 -5 -8)) 19 | (ensure-same (ivec 1 8 2) #(1 3 5 7)))) 20 | 21 | (addtest (arithmetic-tests) 22 | (let ((a #(1 2 3)) 23 | (*lift-equality-test* #'==)) 24 | (ensure-same (normalize1 a) #(1/6 1/3 1/2)))) 25 | -------------------------------------------------------------------------------- /tests/old/array.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (deftestsuite array-tests (cl-num-utils-tests) 6 | () 7 | (:equality-test #'equalp)) 8 | 9 | (addtest (array-tests) 10 | matrix-type-tests 11 | (let ((m (ia 3 4))) 12 | (ensure (typep m 'matrix)) 13 | (ensure (typep m '(matrix *))) 14 | (ensure (typep m '(matrix t))) 15 | (ensure (typep m '(matrix t 3))) 16 | (ensure (typep m '(matrix t * 4))) 17 | (ensure (typep m '(matrix t 3 4))) 18 | (ensure (not (typep m '(matrix * 2)))))) 19 | 20 | (addtest (array-tests) 21 | diagonal 22 | (let ((a1 (ia 2 2)) 23 | (a2 (ia 3 2)) 24 | (a3 (ia 2 3)) 25 | (*lift-equality-test* #'==)) 26 | (ensure-same (diagonal a1) (vector 0 3)) 27 | (ensure-same (diagonal a2) (vector 0 3)) 28 | (ensure-same (diagonal a3) (vector 0 4)))) 29 | 30 | (addtest (array-tests) 31 | (flet ((fill-in-dimensions (dimensions size) 32 | (clnu::fill-in-dimensions dimensions size))) 33 | (ensure-same (fill-in-dimensions '(1 2 3) 6) '(1 2 3)) 34 | (ensure-same (fill-in-dimensions '(1 t 3) 6) '(1 2 3)) 35 | (ensure-same (fill-in-dimensions '(1 t 3) 0) '(1 0 3)) 36 | (ensure-same (fill-in-dimensions 6 6) '(6)) 37 | (ensure-same (fill-in-dimensions t 6) '(6)) 38 | (ensure-error (fill-in-dimensions '(1 t t 3) 6)) 39 | (ensure-error (fill-in-dimensions '(1 t 0 3) 6)))) 40 | 41 | (addtest (array-tests) 42 | reshape 43 | (let ((a (ia 3 4)) 44 | (a-reshaped-rm #2A((0 1 2) 45 | (3 4 5) 46 | (6 7 8) 47 | (9 10 11)))) 48 | (ensure-same (reshape '(4 t) a) a-reshaped-rm) 49 | ;; (ensure-same (reshape a '(4 t) :column-major) 50 | ;; #2A((0 5 10) 51 | ;; (4 9 3) 52 | ;; (8 2 7) 53 | ;; (1 6 11))) 54 | )) 55 | 56 | (addtest (array-tests) 57 | row-and-column 58 | (let ((result #2A((1 2 3))) 59 | (r1 (row 1 2 3)) 60 | (r2 (row-with-type 'fixnum 1 2 3)) 61 | (*lift-equality-test* #'equalp)) 62 | (ensure-same r1 result) 63 | (ensure-same r2 result) 64 | (ensure-same (array-element-type r2) 65 | (upgraded-array-element-type 'fixnum))) 66 | (let ((result #2A((1) (2) (3))) 67 | (c1 (column 1 2 3)) 68 | (c2 (column-with-type 'fixnum 1 2 3)) 69 | (*lift-equality-test* #'equalp)) 70 | (ensure-same c1 result) 71 | (ensure-same c2 result) 72 | (ensure-same (array-element-type c2) 73 | (upgraded-array-element-type 'fixnum)))) 74 | 75 | ;; (addtest (array-tests) 76 | ;; rows-and-columns 77 | ;; (let ((a #2A((1 2) 78 | ;; (3 4) 79 | ;; (5 6))) 80 | ;; (rows (vector #(1 2) #(3 4) #(5 6))) 81 | ;; (columns (vector #(1 3 5) #(2 4 6)))) 82 | ;; (ensure-same (rows a) rows) 83 | ;; (ensure-same (columns a) columns))) 84 | 85 | ;; (addtest (array-tests) 86 | ;; pref 87 | ;; (let ((matrix #2A((0 1) 88 | ;; (2 3) 89 | ;; (4 5))) 90 | ;; (vector #(0 1 2 3))) 91 | ;; (ensure-same (pref matrix #(0 2 1) #(1 0 1)) #(1 4 3)) 92 | ;; (ensure-same (pref vector #(3 1 2 0)) #(3 1 2 0)) 93 | ;; (ensure-error (pref vector #(1) #(0))) 94 | ;; (ensure-error (pref matrix #(1 0) #(0))))) 95 | 96 | 97 | ;; (addtest (array-tests) 98 | ;; filter-rows-test 99 | ;; (let ((matrix (ia 4 3)) 100 | ;; (*lift-equality-test* #'equalp) 101 | ;; (expected-result #2A((0 1 2) (6 7 8)))) 102 | ;; (ensure-same (filter-rows (lambda (vector) (evenp (aref vector 0))) matrix) 103 | ;; expected-result) 104 | ;; (ensure-same (with-filter-rows matrix ; so much simpler, eh? 105 | ;; ((a 0)) 106 | ;; (evenp a)) 107 | ;; expected-result))) 108 | 109 | ;; (addtest (array-tests) 110 | ;; shrink-rows-test 111 | ;; (ensure-same (shrink-rows (array* '(2 5) t 112 | ;; nil 1 2 nil nil 113 | ;; nil nil 3 4 nil)) 114 | ;; (values (array* '(2 3) t 115 | ;; 1 2 nil 116 | ;; nil 3 4) 117 | ;; 1 4)) 118 | ;; (ensure-same (shrink-rows (make-array '(2 3) :initial-element 'foo) 119 | ;; :predicate (lambda (x) (not (eq x 'foo)))) 120 | ;; nil)) 121 | 122 | (addtest (array-tests) 123 | rep 124 | ;; (ensure-same (rep '(1 2 3) 4 2) 125 | ;; '(1 1 2 2 3 3 1 1 2 2 3 3 1 1 2 2 3 3 1 1 2 2 3 3)) 126 | (ensure-same (rep #(1 2 3) 4 2) 127 | #(1 1 2 2 3 3 1 1 2 2 3 3 1 1 2 2 3 3 1 1 2 2 3 3))) 128 | 129 | 130 | (addtest (array-tests) 131 | displace-test 132 | (let ((a (ia 2 3 4)) 133 | (*lift-equality-test* #'equalp)) 134 | (ensure-same (displace-array a '(2 3 4)) a) 135 | (ensure-same (displace-array a '(6 4)) (ia 6 4)) 136 | (ensure-same (displace-array a '(10) 14) (ia* 14 10)) 137 | (ensure-same (displace-array a 10 0) (ia 10)) 138 | (ensure-same (subarray a 0 0) (ia 4)) 139 | (ensure-same (subarray a 1) (ia* 12 3 4)))) 140 | 141 | (addtest (array-tests) 142 | setf-subarray-tests 143 | (let ((a (ia 3 4)) 144 | (*lift-equality-test* #'equalp)) 145 | (setf (subarray a 1) #(4 3 2 1)) 146 | (ensure-same a #2A((0 1 2 3) 147 | (4 3 2 1) 148 | (8 9 10 11))) 149 | (setf (subarray a 1 3) 9) 150 | (ensure-same a #2A((0 1 2 3) 151 | (4 3 2 9) 152 | (8 9 10 11))))) 153 | 154 | (addtest (array-tests) 155 | subarrays-tests 156 | (let ((a (ia 2 3)) 157 | (b (ia 2 2 3)) 158 | (*lift-equality-test* #'equalp)) 159 | (ensure-same (subarrays 0 a) a) 160 | (ensure-same (subarrays 1 a) #(#(0 1 2) #(3 4 5))) 161 | (ensure-same (subarrays 2 a) a) 162 | (ensure-same (subarrays 0 b) b) 163 | (ensure-same (subarrays 1 b) #(#2A((0 1 2) 164 | (3 4 5)) 165 | #2A((6 7 8) 166 | (9 10 11)))) 167 | (ensure-same (subarrays 2 b) #2A((#(0 1 2) #(3 4 5)) 168 | (#(6 7 8) #(9 10 11)))) 169 | (ensure-same (subarrays 3 b) b) 170 | (ensure-error (subarrays 3 a)) 171 | (ensure-error (subarrays -1 a)) 172 | (let* ((c (make-array '(9 5 7) :element-type 'bit 173 | :initial-element 1)) 174 | (c-sub (subarrays 1 c))) 175 | (ensure (every (lambda (x) 176 | (and (eq (array-element-type x) 'bit) 177 | (equal (array-dimensions x) '(5 7)))) 178 | c-sub))))) 179 | 180 | (addtest (array-tests) 181 | partition-tests 182 | (let ((*lift-equality-test* #'equalp) 183 | (a (ia 3 2)) 184 | (b (ia 3))) 185 | (ensure-same (partition a 0) a) 186 | (ensure-same (partition a 1) #2A((2 3) 187 | (4 5))) 188 | (ensure-same (partition a 1 2) #2A((2 3))) 189 | (ensure-same (partition b 0) b) 190 | (ensure-same (partition b 1) #(1 2)) 191 | (ensure-same (partition b 2) #(2)))) 192 | 193 | (addtest (array-tests) 194 | combine-tests 195 | (let ((a (ia 4 3 5)) 196 | (*lift-equality-test* #'==)) 197 | (ensure-same (combine (subarrays 0 a)) a) 198 | (ensure-same (combine (subarrays 1 a)) a) 199 | (ensure-same (combine (subarrays 2 a)) a) 200 | (ensure-same (combine (subarrays 3 a)) a))) 201 | 202 | (addtest (array-tests) 203 | valid-permutation-test 204 | (ensure (valid-permutation? #(0 1 2))) 205 | (ensure (valid-permutation? #(1 0 2))) 206 | (ensure (not (valid-permutation? #(0 1 1)))) 207 | (ensure (not (valid-permutation? #(0 1 2) 4))) 208 | (ensure (not (valid-permutation? #(0 1 2) 2)))) 209 | 210 | (addtest (array-tests) 211 | permutation-test 212 | (let ((a (ia 3 4)) 213 | (b (ia 1 2 3)) 214 | (c (ia 2 2 3)) 215 | (*lift-equality-test* #'equalp)) 216 | (ensure-same (permute a '(0 1)) a) 217 | (ensure-same (permute a '(1 0)) (transpose a)) 218 | (ensure-same (permute b '(1 2 0)) 219 | #3A(((0) (1) (2)) 220 | ((3) (4) (5)))) 221 | (ensure-same (permute c '(2 1 0)) 222 | #3A(((0 6) (3 9)) 223 | ((1 7) (4 10)) 224 | ((2 8) (5 11)))))) 225 | 226 | (addtest (array-tests) 227 | which 228 | (let* ((vector #(7 6 5 4 3 2 1 0)) 229 | (list (coerce vector 'list)) 230 | (even-pos #(1 3 5 7)) 231 | (odd-pos #(0 2 4 6)) 232 | (arbitrary (reverse #(0 2 3 5))) 233 | (arbitrary-pos #(2 4 5 7)) 234 | (*lift-equality-test* #'equalp)) 235 | (ensure-same (which #'oddp vector) odd-pos) 236 | (ensure-same (which #'oddp list) odd-pos) 237 | (ensure-same (which #'evenp vector) even-pos) 238 | (ensure-same (which #'evenp list) even-pos) 239 | (flet ((in? (element) (find element arbitrary))) 240 | (ensure-same (which #'in? vector) arbitrary-pos) 241 | (ensure-same (which #'in? list) arbitrary-pos)))) 242 | 243 | (addtest (array-tests) 244 | mask 245 | (let* ((vector (iseq 6)) 246 | (odd-bits (mask #'oddp vector)) 247 | (even-bits (mask #'evenp vector)) 248 | (div3-bits (mask (lambda (n) (divides? n 3)) vector)) 249 | (*lift-equality-test* #'equalp)) 250 | (ensure-same even-bits #*101010) 251 | (ensure-same odd-bits #*010101) 252 | (ensure-same div3-bits #*100100) 253 | (ensure-same (sub vector even-bits) #(0 2 4)) 254 | (ensure-same (sub vector odd-bits) #(1 3 5)) 255 | (ensure-same (sub vector div3-bits) #(0 3)) 256 | (ensure-same (sub vector (bit-ior even-bits div3-bits)) #(0 2 3 4)))) 257 | 258 | (addtest (array-tests) 259 | bracket-test 260 | (let ((a #(0 1 2 3 4 3 2 1 0))) 261 | (ensure-same (bracket #'plusp a) (cons 1 8)) 262 | (ensure-same (bracket (curry #'<= 3) a) (cons 3 6)) 263 | (ensure-same (bracket (curry #'<= 5) a) nil) 264 | (ensure-same (bracket t #(nil nil nil t t nil nil)) (cons 3 5)))) 265 | 266 | (addtest (array-tests) 267 | norm-test 268 | (let ((a #(1 -2 3)) 269 | (b #(1 #C(0 -4) 3)) 270 | (*lift-equality-test* #'==)) 271 | (ensure-same (norm1 a) 6) 272 | (ensure-same (norm1 b) 8) 273 | (ensure-same (norm2 a) (sqrt 14)) 274 | (ensure-same (norm2 b) (sqrt 26)) 275 | (ensure-same (normsup a) 3) 276 | (ensure-same (normsup b) 4))) 277 | 278 | (addtest (array-tests) 279 | map-columns 280 | (ensure-same (map-columns #'sum (ia 3 4)) 281 | #(12 15 18 21)) 282 | (ensure-same (map-columns (lambda (col) (vector (sum col) (mean col))) (ia 3 4)) 283 | #2A((12 15 18 21) 284 | (4 5 6 7)))) 285 | 286 | (addtest (array-tests) 287 | recycle-row-col 288 | (let ((v (vector* 'fixnum 1 2 3)) 289 | (*lift-equality-test* #'array=)) 290 | (ensure-same (recycle-row v 4) 291 | (matrix* 'fixnum v v v v)) 292 | (ensure-same (recycle-column v 4) 293 | (matrix* 'fixnum 294 | '(1 1 1 1) 295 | '(2 2 2 2) 296 | '(3 3 3 3))))) 297 | 298 | (addtest (array-tests) 299 | row-col-sum-mean 300 | (let ((a #2A((1 2 3) 301 | (4 5 6))) 302 | (*lift-equality-test* #'equalp)) 303 | (ensure-same (row-sums a) #(6 15)) 304 | (ensure-same (row-means a) #(2 5)) 305 | (ensure-same (column-sums a) #(5 7 9)) 306 | (ensure-same (column-means a) #(5/2 7/2 9/2)))) 307 | -------------------------------------------------------------------------------- /tests/old/bins.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (deftestsuite bins-tests (cl-num-utils-tests) 6 | ()) 7 | 8 | (defmacro with-check-bin-index ((bins) &body body) 9 | "Within BODY, (CHECK-BIN-INDEX VALUE INDEX) will check that both 10 | BIN-INDEX and BIN-FUNCTION map VALUE to INDEX." 11 | (once-only (bins) 12 | `(macrolet ((check-bin-index (value index) 13 | `(ensure-same (bin-index ,',bins ,value) ,index))) 14 | ,@body))) 15 | 16 | (addtest (bins-tests) 17 | even-bins 18 | (let* ((width 2) 19 | (offset 1) 20 | (bins (even-bins width offset)) 21 | (index-start -5) 22 | (left-start (+ (* index-start width) offset))) 23 | (with-check-bin-index (bins) 24 | (iter 25 | (for index :from index-start :to (* 2 (abs index-start))) 26 | (for left :from left-start :by width) 27 | (for middle :from (+ left-start 0.001) :by width) 28 | (for right :from (+ left-start width) :by width) 29 | (check-bin-index left index) 30 | (check-bin-index middle index) 31 | (check-bin-index right (1+ index)))))) 32 | 33 | ;; (addtest (bins-tests) 34 | ;; irregular-bins 35 | ;; (let* ((bins (irregular-bins #(1 2 3 4)))) 36 | ;; (with-check-bin-index (bins) 37 | ;; (check-bin-index 1 0) 38 | ;; (check-bin-index 1.5 0) 39 | ;; (check-bin-index 2 1)) 40 | ;; (ensure-error (bin-value bins 0)) 41 | ;; (ensure-error (bin-value bins 4)))) 42 | 43 | (addtest (bins-tests) 44 | binary-search 45 | (flet ((test-binary-search (n &key (max n)) 46 | "Test fixnum binary search by generating N random elements below 47 | MAX, then finding a random number." 48 | (let* ((vector (sort 49 | (remove-duplicates (generate-array n (curry #'random max))) 50 | #'<=)) 51 | (value (random max)) 52 | (index (position value vector)) ; the hard way 53 | (result (binary-search vector value))) 54 | (cond 55 | ((not index) 56 | (assert (not result) () 57 | "~A mistakenly found in ~A at index ~A" 58 | value vector result) 59 | t) 60 | ((not result) 61 | (error "~A not found in ~A" value vector)) 62 | ((/= index result) 63 | (error "~A found in ~A at location ~A instead of ~A" 64 | value vector result index)) 65 | (t t))))) 66 | (loop repeat 10000 do 67 | (ensure (test-binary-search (1+ (random 40))))))) 68 | -------------------------------------------------------------------------------- /tests/old/data-frame.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (deftestsuite data-frame-tests (cl-num-utils-tests) 6 | () 7 | (:equality-test #'==)) 8 | 9 | (addtest (data-frame-tests) 10 | simple-data-frame-tests 11 | (let* ((matrix (ia 2 3)) 12 | (sub-matrix #2A((0 2) (3 5))) 13 | (sub-vector #(1 4)) 14 | (df (matrix-to-data-frame matrix #(a b c)))) 15 | (ensure-same (sub df t 'b) sub-vector) 16 | (ensure-same (sub df t (vector 'a 'c)) 17 | (matrix-to-data-frame sub-matrix #(a c))) 18 | ;; should pass through regular arguments 19 | (ensure-same (sub df t t) df))) 20 | 21 | (addtest (data-frame-tests) 22 | data-frame-setf-tests 23 | (let* ((matrix (ia 3 4)) 24 | (df (matrix-to-data-frame matrix '(a b c d))) 25 | (sub-vector (ia 3))) 26 | (setf (sub df t 'c) sub-vector 27 | (sub matrix t 2) sub-vector) 28 | (ensure-same (as-array df) matrix))) 29 | 30 | (addtest (data-frame-tests) 31 | data-frame-map 32 | (let* ((ab '((a . #(3 5 7)) 33 | (b . #(1 2 3)))) 34 | (df (make-data-frame ab)) 35 | (c #(4 7 10)) 36 | (abc (make-data-frame (append ab (list (cons 'c c)))))) 37 | (ensure-same (map-data-frame df '(a b) #'+) c) 38 | (ensure-same (map-into-data-frame (copy-data-frame df) '(a b) #'+ 'c) 39 | abc) 40 | (ensure-same (add-column (copy-data-frame df) 'c c) abc))) 41 | 42 | ;; (addtest (data-frame-tests) 43 | ;; data-frame-filter-tests 44 | ;; (let* ((matrix (ia 4 3)) 45 | ;; (keys '(a b (c foo))) 46 | ;; (*lift-equality-test* #'equalp) 47 | ;; (expected-result (make-data-frame #2A((6 7 8)) keys)) 48 | ;; (df (make-data-frame matrix keys))) 49 | ;; (ensure-same (with-filter-data-frame df (a (c '(c foo))) 50 | ;; (and (evenp a) (= c 8))) 51 | ;; expected-result))) 52 | 53 | ;; (addtest (data-frame-tests) 54 | ;; (let* ((matrix (array* '(2 3) t 55 | ;; 1 2 3 56 | ;; 5 6 7)) 57 | ;; (shrunk-matrix (array* '(2 1) t 2 6)) 58 | ;; (data-frame (make-data-frame matrix '(a b c))) 59 | ;; (shrunk-data-frame (shrink-rows data-frame :predicate #'evenp))) 60 | ;; (ensure-same (as-array shrunk-data-frame) shrunk-matrix) 61 | ;; (ensure-same (ix-keys shrunk-data-frame) (sub (ix-keys data-frame) (si 1 2))))) 62 | -------------------------------------------------------------------------------- /tests/old/differentiation.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (deftestsuite differentiation-tests (cl-num-utils-tests) 6 | () 7 | (:equality-test #'==)) 8 | 9 | (addtest (differentiation-tests) 10 | differentiation1 11 | (let ((f #'sin) 12 | (fp #'cos)) 13 | (ensure-same (differentiate f 0d0) (funcall fp 0d0)) 14 | (ensure-same (differentiate f 0.5d0) (funcall fp 0.5d0)))) 15 | 16 | (addtest (differentiation-tests) 17 | elasticity1 18 | (let+ ((alpha 2d0) 19 | ((&flet f (x) (expt x alpha))) 20 | (elas (elasticity #'f))) 21 | (ensure-same (funcall elas 2d0) alpha) 22 | (ensure-same (funcall elas 7d0) alpha))) 23 | 24 | (addtest (differentiation-tests) 25 | differentiation2 26 | (ensure-same 27 | (differentiate (lambda (x) (let+ ((#(x0 x1) x)) (+ (expt x0 2) (* 3 x1)))) #(0 0)) 28 | #(0 3))) 29 | -------------------------------------------------------------------------------- /tests/old/interactions.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (deftestsuite interactions-tests (cl-num-utils-tests) 6 | ()) 7 | 8 | (addtest (interactions-tests) 9 | simple-interactions-tests 10 | (let ((*lift-equality-test* #'equalp)) 11 | (let+ (((&slots indexes keys) 12 | (interaction #(0 0 1) #(0 1 1)))) 13 | (ensure-same indexes #(0 1 2)) 14 | (ensure-same keys #(#(0 0) #(0 1) #(1 1)))) 15 | (let+ (((&slots indexes keys) 16 | (interaction #(0 2 1) #(0 1 2)))) 17 | (ensure-same indexes #(0 2 1)) 18 | (ensure-same keys #(#(0 0) #(1 2) #(2 1)))))) 19 | -------------------------------------------------------------------------------- /tests/old/sub.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (deftestsuite sub-tests (cl-num-utils-tests) 6 | () 7 | (:equality-test #'equalp)) 8 | 9 | (addtest (sub-tests) 10 | test-sub 11 | (let ((a (ia 3 4)) 12 | (*lift-equality-test* #'equalp)) 13 | (ensure-same (sub a (cons 0 -1) (cons 0 -1)) 14 | #2A((0 1 2) 15 | (4 5 6))) 16 | (ensure-same (sub a (cons 1 -1) t) 17 | #2A((4 5 6 7))) 18 | (ensure-same (sub a (incl 1 1) t) 19 | #2A((4 5 6 7))) 20 | (ensure-same (sub a 1 t) 21 | #(4 5 6 7)) 22 | (ensure-same (sub a (rev t) (cat (cons 0 2) (cons 2 4))) 23 | #2A((8 9 10 11) 24 | (4 5 6 7) 25 | (0 1 2 3))) 26 | (ensure-same (sub a t 2) #(2 6 10)) 27 | (ensure (not (equalp (sub a 1 t) 28 | #2A((4 5 6 7))))))) 29 | 30 | (addtest (sub-tests) 31 | test-setf-sub 32 | (let ((b (ia 2 3)) 33 | (*lift-equality-test* #'equalp)) 34 | (let ((a (ia 3 4))) 35 | (ensure-same (setf (sub a (cons 1 nil) (cons 1 nil)) b) b) 36 | (ensure-same a #2A((0 1 2 3) 37 | (4 0 1 2) 38 | (8 3 4 5))) 39 | (ensure-same b (ia 2 3))) 40 | (let ((a (ia 3 4))) 41 | (ensure-same (setf (sub a (cons 0 -1) #(3 2 1)) b) b) 42 | (ensure-same a #2A((0 2 1 0) 43 | (4 5 4 3) 44 | (8 9 10 11))) 45 | (ensure-same b (ia 2 3)) 46 | (ensure-error (setf (sub a 2 4) (list 3))) 47 | (ensure-error (setf (sub a 2 4) (vector 3)))))) 48 | 49 | (addtest (sub-tests) 50 | test-sub-ivec 51 | (let ((a (ivec 10))) 52 | (ensure-same (sub a (ivec* 0 nil)) a) 53 | (ensure-same (sub a (ivec* 0 nil 1)) a) 54 | (ensure-same (sub a (ivec* 0 nil 2)) #(0 2 4 6 8)) 55 | (ensure-same (sub a (ivec* 0 9 2)) #(0 2 4 6 8)) 56 | (ensure-same (sub a (ivec* 0 8 2)) #(0 2 4 6)) 57 | (ensure-same (sub a (ivec* 1 9 2)) #(1 3 5 7)) 58 | (ensure-same (sub a (ivec* 1 -1 2)) #(1 3 5 7)) 59 | (ensure-same (sub a (ivec* 1 nil 2)) #(1 3 5 7 9)) 60 | (ensure-same (sub a (ivec* 0 nil 3)) #(0 3 6 9)) 61 | (ensure-same (sub a (ivec* 0 -1 3)) #(0 3 6)) 62 | (ensure-same (sub a (ivec* 1 -1 3)) #(1 4 7)) 63 | (ensure-same (sub a (ivec* 1 7 3)) #(1 4)) 64 | (ensure-same (sub a (sub (rev (ivec* 0 nil 3)) #(0 1))) #(9 6)))) 65 | 66 | (addtest (sub-tests) 67 | test-asub 68 | (ensure-same (asub (ia 10) (mask #'evenp it)) #(0 2 4 6 8))) 69 | -------------------------------------------------------------------------------- /tests/old/test-utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defun random-vector (length element-type &optional (arg (coerce 1 element-type))) 6 | (aprog1 (make-array length :element-type element-type) 7 | (dotimes (index length) 8 | (setf (aref it index) (random arg))))) 9 | 10 | (defun array= (array1 array2) 11 | "Test that arrays are equal and have the same element type." 12 | (and (type= (array-element-type array1) 13 | (array-element-type array2)) 14 | (equalp array1 array2))) 15 | 16 | (defun array* (dimensions element-type &rest elements) 17 | "Return a (SIMPLE-ARRAY ELEMENT-TYPE dimensions) containing ELEMENTS, 18 | coerced to ELEMENT-TYPE." 19 | (aprog1 (make-array dimensions :element-type element-type) 20 | (dotimes (index (array-total-size it)) 21 | (assert elements () "Not enough elements.") 22 | (setf (row-major-aref it index) (coerce (car elements) element-type) 23 | elements (cdr elements))) 24 | (assert (not elements) () "Too many elements (~A)." elements))) 25 | 26 | (defun vector* (element-type &rest elements) 27 | "Return a (SIMPLE-ARRAY ELEMENT-TYPE (*)) containing ELEMENTS, 28 | coerced to ELEMENT-TYPE." 29 | (apply #'array* (length elements) element-type elements)) 30 | 31 | (defun iseq (n &optional (type 'fixnum)) 32 | "Return a sequence of integers. If type is LIST, a list is returned, 33 | otherwise a vector with the corresponding upgraded element type." 34 | (if (eq type 'list) 35 | (loop for i below n collect i) 36 | (aprog1 (make-array n :element-type type) 37 | (dotimes (i n) 38 | (setf (aref it i) (coerce i type)))))) 39 | 40 | 41 | ;;; utilities 42 | 43 | (defun ia* (start &rest dimensions) 44 | "Return an array with given dimensions, filled with integers from START, 45 | in row-major order. For testing purposes." 46 | (aprog1 (make-array dimensions) 47 | (iter 48 | (for i :from 0 :below (array-total-size it)) 49 | (for value :from start) 50 | (setf (row-major-aref it i) value)))) 51 | 52 | (defun ia (&rest dimensions) 53 | "Return an array with given dimensions, filled with integers from 0, 54 | in row-major order. For testing purposes." 55 | (apply #'ia* 0 dimensions)) 56 | -------------------------------------------------------------------------------- /tests/old/utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (deftestsuite utilities-tests (cl-num-utils-tests) 6 | () 7 | (:equality-test #'==)) 8 | 9 | ;;; FIXME re-add 10 | ;; (addtest (utilities-tests) 11 | ;; demean-test 12 | ;; (ensure-same (demean #(0 1 2)) (values #(-1 0 1) 1))) 13 | -------------------------------------------------------------------------------- /tests/polynomial.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | ;;; Although not used here, see: 8 | ;;; https://www.semanticscholar.org/paper/A-Simple-Test-Qualifying-the-Accuracy-of-Horner'S-Boldo-Daumas/fe5b9e5996947395680c9fb0c3dd918728e043fe 9 | ;;; For a methodology for testing Horner's rule for polynomials. 10 | 11 | (def-suite polynomial 12 | :description "Test evaluation of polynomials using Horner's rule" 13 | :in all-tests) 14 | (in-suite polynomial) 15 | 16 | ;;; Fixnum 17 | (defvar polynomial-f1 (make-vector 'fixnum 2 -6 2 -1)) ; Answer: 5, for x = 3 18 | (defvar polynomial-f2 (make-vector 'fixnum 2 0 3 1)) ; Answer: 23, for x = 2 19 | (defvar polynomial-f3 (make-vector 'fixnum 1 3 5 7 9)) ; Answer: 83, for x = 2 20 | 21 | ;;; Single float 22 | (defvar polynomial-s1 (make-vector 'single-float 2.0 -6.0 2.0 -1.0)) ; Answer: 5, for x = 3 23 | (defvar polynomial-s2 (make-vector 'single-float 2.0 0.0 3.0 1.0)) ; Answer: 23, for x = 2 24 | (defvar polynomial-s3 (make-vector 'single-float 1.0 3.0 5.0 7.0 9.0)) ; Answer: 83, for x = 2 25 | 26 | ;;; Double float 27 | (defvar polynomial-d1 (make-vector 'double-float 2.0d0 -6.0d0 2.0d0 -1.0d0)) ; Answer: 5, for x = 3 28 | (defvar polynomial-d2 (make-vector 'double-float 2.0d0 0.0d0 3.0d0 1.0d0)) ; Answer: 23, for x = 2 29 | (defvar polynomial-d3 (make-vector 'double-float 1.0d0 3.0d0 5.0d0 7.0d0 9.0d0)) ; Answer: 83, for x = 2 30 | 31 | ;;; Bignum and everything else 32 | (defvar polynomial-b1 #(2 0 1)) 33 | (defvar polynomial-b2 #(2 0 3 1)) 34 | (defvar polynomial-b3 #(1 3 5 7 9)) 35 | 36 | (test fixnum-polynomial 37 | :description "Test Horner's method of polynomial evaluation with fixnum coefficients." 38 | (let ((answer (evaluate-polynomial polynomial-f1 3))) 39 | (is (equal 5 answer) "Expected 5 but got ~A." answer)) 40 | (let ((answer (evaluate-polynomial polynomial-f2 2))) 41 | (is (equal 23 answer) "Expected 23 but got ~A." answer)) 42 | (let ((answer (evaluate-polynomial polynomial-f3 2))) 43 | (is (equal 83 answer) "Expected 82 but got ~A." answer)) 44 | (let ((answer (evaluate-polynomial (make-vector 'fixnum 5) 2))) ; Test with single coefficient 45 | (is (equal 5 answer) "Expected 5 but got ~A." answer))) 46 | 47 | (test single-float-polynomial 48 | :description "Test Horner's method of polynomial evaluation with single-float coefficients." 49 | (let ((answer (evaluate-polynomial polynomial-s1 3.0))) 50 | (is (equal 5.0 answer) "Expected 5.0 but got ~A." answer)) 51 | (let ((answer (evaluate-polynomial polynomial-s2 2.0))) 52 | (is (equal 23.0 answer) "Expected 23.0 but got ~A." answer)) 53 | (let ((answer (evaluate-polynomial polynomial-s3 2.0))) 54 | (is (equal 83.0 answer) "Expected 82.0 but got ~A." answer))) 55 | 56 | (test double-float-polynomial 57 | :description "Test Horner's method of polynomial evaluation with double-float coefficients." 58 | (let ((answer (evaluate-polynomial polynomial-d1 3.0d0))) 59 | (is (equal 5.0d0 answer) "Expected 5.0d0 but got ~A." answer)) 60 | (let ((answer (evaluate-polynomial polynomial-d2 2.0d0))) 61 | (is (equal 23.0d0 answer) "Expected 23.0d0 but got ~A." answer)) 62 | (let ((answer (evaluate-polynomial polynomial-d3 2.0d0))) 63 | (is (equal 83.0d0 answer) "Expected 82.0d0 but got ~A." answer))) 64 | 65 | (test untyped-polynomial 66 | :description "Test Horner's method of polynomial evaluation with untyped coefficients." 67 | (let ((answer (evaluate-polynomial polynomial-b1 (1+ most-positive-fixnum)))) 68 | (is (eql 42535295865117307932921825928971026433 answer) 69 | "Expected 42535295865117307932921825928971026433 but got ~A." answer))) 70 | -------------------------------------------------------------------------------- /tests/quadrature.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | (def-suite quadrature 8 | :description "Tests quadrature functions" 9 | :in all-tests) 10 | (in-suite quadrature) 11 | 12 | (test integration-finite 13 | (flet ((test-romberg (function interval value &rest rest) 14 | (let+ (((&interval a b) interval) 15 | (closed-interval (interval a b)) 16 | (open-interval (interval a b :open-left? t :open-right? t))) 17 | (is (num=-function 1e-5) 18 | (apply #'romberg-quadrature function closed-interval rest) 19 | value) 20 | (is (num=-function 1e-5) 21 | (apply #'romberg-quadrature function open-interval rest) 22 | value)))) 23 | (test-romberg (constantly 1d0) (interval 0 2) 2d0) 24 | (test-romberg #'identity (interval 1 5) 12d0) 25 | (test-romberg (lambda (x) (/ (exp (- (/ (expt x 2) 2))) 26 | (sqrt (* 2 pi)))) 27 | (interval 0 1) 0.3413447460685429d0 :epsilon 1d-9))) 28 | 29 | (test integration-plusinf 30 | (is (num= 1 31 | (romberg-quadrature (lambda (x) (expt x -2)) 32 | (interval 1 :plusinf)))) 33 | (is (num= 1/3 34 | (romberg-quadrature (lambda (x) (exp (* -3 x))) 35 | (interval 0 :plusinf))))) 36 | -------------------------------------------------------------------------------- /tests/rootfinding.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | #+genera (setf *print-array* t) 6 | 7 | (def-suite root-finding 8 | :description "Tests root finding functions" 9 | :in all-tests) 10 | (in-suite root-finding) 11 | 12 | (test bisection-test 13 | (let ((*rootfinding-delta-relative* 1e-6) 14 | (*num=-tolerance* 1d-2)) 15 | (is (num= 0 (root-bisection #'identity (interval -1 2)))) 16 | (is (num= 5 (root-bisection (lambda (x) 17 | (expt (- x 5) 3)) 18 | (interval -1 10)))))) 19 | 20 | -------------------------------------------------------------------------------- /tests/test-package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: CL-USER -*- 2 | ;;; Copyright (c) 2021-2023 by Symbolics Pte. Ltd. All rights reserved. 3 | ;;; SPDX-License-identifier: MS-PL 4 | 5 | (uiop:define-package #:num-utils-tests 6 | (:use #:cl 7 | #:alexandria 8 | #:anaphora 9 | #:let-plus 10 | #:fiveam 11 | #:select 12 | 13 | ;; num-utils subpackages (alphabetical order) 14 | #:num-utils.arithmetic 15 | #:num-utils.chebyshev 16 | #:num-utils.elementwise 17 | #:num-utils.interval 18 | #:num-utils.log-exp 19 | #:num-utils.matrix 20 | #:num-utils.matrix-shorthand 21 | #:num-utils.num= 22 | #:num-utils.polynomial 23 | #:num-utils.quadrature 24 | #:num-utils.rootfinding 25 | #:num-utils.test-utilities 26 | #:num-utils.utilities) 27 | (:export #:run)) 28 | -------------------------------------------------------------------------------- /tests/utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: NUM-UTILS-TESTS -*- 2 | ;;; Copyright (c) 2019, 2022 by Symbolics Pte. Ltd. All rights reserved. 3 | (in-package #:num-utils-tests) 4 | 5 | (def-suite utilities 6 | :description "Test utility functions" 7 | :in all-tests) 8 | (in-suite utilities) 9 | 10 | (test gethash 11 | (let ((table (make-hash-table :test #'eq))) 12 | (setf (gethash 'a table) 1) 13 | (is (= 1 (gethash* 'a table))) 14 | (signals error (gethash* 'b table)))) 15 | 16 | (test biconditional 17 | (is (bic t t)) 18 | (is (bic nil nil)) 19 | (not (bic t nil)) 20 | (not (bic nil t))) 21 | 22 | (test splice-when 23 | (is (equal '(a b c) `(a ,@(splice-when t 'b) c))) 24 | (is (equal '(a c) `(a ,@(splice-when nil 'b) c))) 25 | (is (equal '(a b c) `(a ,@(splice-awhen 'b it) c))) 26 | (is (equal '(a c) `(a ,@(splice-awhen (not 'b) it) c)))) 27 | 28 | (test with-double-floats 29 | (let ((a 1) 30 | (c 4) 31 | (d 5)) 32 | (with-double-floats ((a 2) 33 | (b a) 34 | c 35 | (d)) 36 | (is (= a 2d0)) 37 | (is (= b 1d0)) 38 | (is (= c 4d0)) 39 | (is (= d 5d0))))) 40 | 41 | (test boolean 42 | (let ((a #(nil nil t t)) 43 | (b #(nil nil t 5)) 44 | (c #*0011)) 45 | (is (typep a 'simple-boolean-vector)) 46 | (not (typep b 'simple-boolean-vector)) 47 | (is (equal c (as-bit-vector a))))) 48 | 49 | ;;; TODO (Papp): write tests for other utilities 50 | 51 | --------------------------------------------------------------------------------