├── .gitignore ├── doc ├── Makefile ├── bibliography.bib ├── bibliography_bib.html └── bibliography.html ├── tests ├── old │ ├── utilities.lisp │ ├── interactions.lisp │ ├── arithmetic.lisp │ ├── differentiation.lisp │ ├── test-utilities.lisp │ ├── data-frame.lisp │ ├── sub.lisp │ ├── bins.lisp │ └── array.lisp ├── rootfinding.lisp ├── setup.lisp ├── utilities.lisp ├── quadrature.lisp ├── chebyshev.lisp ├── num=.lisp ├── interval.lisp ├── matrix.lisp ├── matrix-shorthand.lisp ├── arithmetic.lisp ├── elementwise.lisp ├── extended-real.lisp └── statistics.lisp ├── src ├── old │ ├── conditions.lisp │ ├── sparse-array.lisp │ ├── pretty.lisp │ ├── interaction.lisp │ ├── differentiation.lisp │ ├── optimization.lisp │ ├── bins.lisp │ ├── misc.lisp │ └── unused.lisp ├── common-package.lisp ├── num=.lisp ├── print-matrix.lisp ├── matrix-shorthand.lisp ├── extended-real.lisp ├── chebyshev.lisp ├── utilities.lisp ├── quadrature.lisp ├── elementwise.lisp ├── rootfinding.lisp ├── arithmetic.lisp ├── matrix.lisp └── interval.lisp ├── README.org ├── LICENSE_1_0.txt ├── cl-num-utils.asd └── arithmetic-type.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl 3 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | bibliography.html: bibliography.bib 2 | bibtex2html $< 3 | -------------------------------------------------------------------------------- /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/rootfinding.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (cl:in-package #:cl-num-utils-tests) 4 | 5 | (defsuite rootfinding-tests (tests)) 6 | 7 | (deftest bisection-test (rootfinding-tests) 8 | (let ((*rootfinding-delta-relative* 1e-6) 9 | (*num=-tolerance* 1d-2)) 10 | (assert-equality #'num= 0 (root-bisection #'identity (interval -1 2))) 11 | (assert-equality #'num= 5 12 | (root-bisection (lambda (x) 13 | (expt (- x 5) 3)) 14 | (interval -1 10))))) 15 | -------------------------------------------------------------------------------- /doc/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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 12 | correct. May be the result of numerical imprecision. Please report it as a 13 | bug.")) 14 | 15 | (define-condition not-implemented () 16 | () 17 | (:report "This functionality is not implemented yet. If you need it, please 18 | report it as an issue.") 19 | (:documentation "Placeholder condition for functionality that is not 20 | implemented yet.")) 21 | -------------------------------------------------------------------------------- /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/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/setup.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | (cl:defpackage #:cl-num-utils-tests 3 | (:use #:cl 4 | #:alexandria 5 | #:anaphora 6 | #:let-plus 7 | #:clunit 8 | #:cl-slice 9 | ;; cl-num-utils subpackages (alphabetical order) 10 | #:cl-num-utils.arithmetic 11 | #:cl-num-utils.chebyshev 12 | #:cl-num-utils.elementwise 13 | #:cl-num-utils.interval 14 | #:cl-num-utils.matrix 15 | #:cl-num-utils.matrix-shorthand 16 | #:cl-num-utils.num= 17 | #:cl-num-utils.quadrature 18 | #:cl-num-utils.statistics 19 | #:cl-num-utils.rootfinding 20 | #:cl-num-utils.utilities) 21 | (:shadowing-import-from #:cl-num-utils.statistics #:mean :variance #:median) 22 | (:export 23 | #:run)) 24 | 25 | (cl:in-package :cl-num-utils-tests) 26 | 27 | (defsuite tests ()) 28 | 29 | (defun run (&optional interactive?) 30 | "Run all tests in the test suite." 31 | (run-suite 'tests :use-debugger interactive?)) 32 | -------------------------------------------------------------------------------- /src/common-package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (unless (find-package '#:cl-num-utils) 5 | (defpackage #:cl-num-utils 6 | (:nicknames #:clnu) 7 | (:use #:cl)))) 8 | 9 | (eval-when (:compile-toplevel :load-toplevel :execute) 10 | (in-package #:cl-num-utils) 11 | 12 | (flet ((reexport (package) 13 | "Reexport all external symbols of package." 14 | (let ((package (find-package package))) 15 | (do-external-symbols (symbol package) 16 | (when (eq (symbol-package symbol) package) 17 | (import symbol) 18 | (export symbol)))))) 19 | (reexport '#:cl-num-utils.arithmetic) 20 | (reexport '#:cl-num-utils.chebyshev) 21 | (reexport '#:cl-num-utils.elementwise) 22 | (reexport '#:cl-num-utils.interval) 23 | (reexport '#:cl-num-utils.matrix) 24 | (reexport '#:cl-num-utils.num=) 25 | (reexport '#:cl-num-utils.statistics) 26 | (reexport '#:cl-num-utils.utilities) 27 | (reexport '#:cl-num-utils.rootfinding) 28 | (reexport '#:cl-num-utils.quadrature))) 29 | -------------------------------------------------------------------------------- /tests/utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defsuite utilities-tests (tests)) 6 | 7 | (deftest gethash-test (utilities-tests) 8 | (let ((table (make-hash-table :test #'eq))) 9 | (setf (gethash 'a table) 1) 10 | (assert-eql 1 (gethash* 'a table)) 11 | (assert-condition error (gethash* 'b table)))) 12 | 13 | (deftest biconditional-test (utilities-tests) 14 | (assert-true (bic t t)) 15 | (assert-true (bic nil nil)) 16 | (assert-false (bic t nil)) 17 | (assert-false (bic nil t))) 18 | 19 | (deftest splice-when (utilities-tests) 20 | (assert-equal '(a b c) `(a ,@(splice-when t 'b) c)) 21 | (assert-equal '(a c) `(a ,@(splice-when nil 'b) c)) 22 | (assert-equal '(a b c) `(a ,@(splice-awhen 'b it) c)) 23 | (assert-equal '(a c) `(a ,@(splice-awhen (not 'b) it) c))) 24 | 25 | (deftest with-double-floats (utilities-tests) 26 | (let ((a 1) 27 | (c 4) 28 | (d 5)) 29 | (with-double-floats ((a 2) 30 | (b a) 31 | c 32 | (d)) 33 | (assert-eql a 2d0) 34 | (assert-eql b 1d0) 35 | (assert-eql c 4d0) 36 | (assert-eql d 5d0)))) 37 | 38 | ;;; FIXME: write tests for other utilities 39 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * cl-num-utils 2 | 3 | This library implements simple numerical functions for Common Lisp, including 4 | 5 | - =num==, a comparison operator for floats 6 | - simple arithmeric functions, like =sum= and =l2norm= 7 | - elementwise operations for arrays 8 | - intervals 9 | - special matrices and shorthand for their input 10 | - sample statistics 11 | - Chebyshev polynomials 12 | - univariate rootfinding 13 | 14 | See the sources and the docstring for more details. 15 | 16 | All the functionality has corresponding unit tests. 17 | 18 | ** Symbol conflicts with =alexandria= 19 | 20 | When you import both =cl-num-utils= and =alexandria=, you get symbol conflicts. There are two solutions for this: either import only parts of =cl-num-utils= (see the packages named in each file), or shadow some symbols, eg 21 | #+BEGIN_SRC lisp 22 | (cl:defpackage #:my-package 23 | (:use #:cl 24 | #:alexandria 25 | #:cl-num-utils) 26 | (:shadowing-import-from #:alexandria #:mean #:variance #:median)) 27 | #+END_SRC 28 | 29 | ** Reporting bugs 30 | 31 | Bugs are tracked on Github, please [[https://github.com/tpapp/cl-num-utils/issues][open an issue]] if you find one. 32 | 33 | ** Tasks 34 | *** TODO finish histogram code, write tests 35 | *** TODO decide whether recursive indexes are practical 36 | code is still there, but commented out 37 | -------------------------------------------------------------------------------- /doc/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 | -------------------------------------------------------------------------------- /LICENSE_1_0.txt: -------------------------------------------------------------------------------- 1 | Boost Software License - Version 1.0 - August 17th, 2003 2 | 3 | Permission is hereby granted, free of charge, to any person or organization 4 | obtaining a copy of the software and accompanying documentation covered by 5 | this license (the "Software") to use, reproduce, display, distribute, 6 | execute, and transmit the Software, and to prepare derivative works of the 7 | Software, and to permit third-parties to whom the Software is furnished to 8 | do so, all subject to the following: 9 | 10 | The copyright notices in the Software and this entire statement, including 11 | the above license grant, this restriction and the following disclaimer, 12 | must be included in all copies of the Software, in whole or in part, and 13 | all derivative works of the Software, unless such copies or derivative 14 | works are solely in the form of machine-executable object code generated by 15 | a source language processor. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT 20 | SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE 21 | FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE, 22 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | DEALINGS IN THE SOFTWARE. 24 | -------------------------------------------------------------------------------- /tests/quadrature.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defsuite quadrature-tests (tests)) 6 | 7 | (deftest integration-finite (quadrature-tests) 8 | (flet ((test-romberg (function interval value &rest rest) 9 | (let+ (((&interval a b) interval) 10 | (closed-interval (interval a b)) 11 | (open-interval (interval a b :open-left? t :open-right? t))) 12 | (assert-equality (num=-function 1e-5) 13 | (apply #'romberg-quadrature function closed-interval rest) 14 | value) 15 | (assert-equality (num=-function 1e-5) 16 | (apply #'romberg-quadrature function open-interval rest) 17 | value)))) 18 | (test-romberg (constantly 1d0) (interval 0 2) 2d0) 19 | (test-romberg #'identity (interval 1 5) 12d0) 20 | (test-romberg (lambda (x) (/ (exp (- (/ (expt x 2) 2))) 21 | (sqrt (* 2 pi)))) 22 | (interval 0 1) 0.3413447460685429d0 :epsilon 1d-9))) 23 | 24 | (deftest integration-plusinf (quadrature-tests) 25 | (assert-equality #'num= 1 26 | (romberg-quadrature (lambda (x) (expt x -2)) 27 | (interval 1 (xreal:inf)))) 28 | (assert-equality #'num= 1/3 29 | (romberg-quadrature (lambda (x) (exp (* -3 x))) 30 | (interval 0 (xreal:inf))))) 31 | -------------------------------------------------------------------------------- /doc/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 | -------------------------------------------------------------------------------- /cl-num-utils.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright Tamas Papp 2010. 2 | ;;; 3 | ;;; Distributed under the Boost Software License, Version 1.0. (See 4 | ;;; accompanying file LICENSE_1_0.txt or copy at 5 | ;;; http://www.boost.org/LICENSE_1_0.txt) 6 | ;;; 7 | ;;; This copyright notice pertains to all files in this library. 8 | 9 | (asdf:defsystem #:cl-num-utils 10 | :description "Numerical utilities for Common Lisp" 11 | :version "0.1" 12 | :author "Tamas K Papp " 13 | :license "Boost Software License - Version 1.0" 14 | #+asdf-unicode :encoding #+asdf-unicode :utf-8 15 | :depends-on (#:anaphora 16 | #:alexandria 17 | #:array-operations 18 | #:cl-slice 19 | #:let-plus) 20 | :pathname "src/" 21 | :serial t 22 | :components 23 | ((:file "utilities") 24 | (:file "num=") 25 | (:file "arithmetic") 26 | (:file "elementwise") 27 | (:file "extended-real") 28 | (:file "interval") 29 | (:file "print-matrix") 30 | (:file "matrix") 31 | (:file "matrix-shorthand") 32 | (:file "statistics") 33 | (:file "chebyshev") 34 | (:file "rootfinding") 35 | (:file "quadrature") 36 | (:file "common-package"))) 37 | 38 | (asdf:defsystem #:cl-num-utils-tests 39 | :description "Unit tests for CL-NUM-UTILS.." 40 | :author "Tamas K Papp " 41 | :license "Same as CL-NUM-UTILS -- this is part of the CL-NUM-UTILS library." 42 | #+asdf-unicode :encoding #+asdf-unicode :utf-8 43 | :depends-on (#:cl-num-utils 44 | #:clunit) 45 | :pathname "tests/" 46 | :serial t 47 | :components 48 | ((:file "setup") 49 | ;; in alphabetical order 50 | (:file "arithmetic") 51 | (:file "chebyshev") 52 | (:file "elementwise") 53 | (:file "extended-real") 54 | (:file "interval") 55 | (:file "matrix") 56 | (:file "matrix-shorthand") 57 | (:file "num=") 58 | (:file "statistics") 59 | (:file "utilities") 60 | (:file "rootfinding"))) 61 | -------------------------------------------------------------------------------- /tests/chebyshev.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defsuite chebyshev-tests (tests)) 6 | 7 | (defun maximum-on-grid (f interval &optional (n-grid 1000)) 8 | "Maximum of F on a grid of N-GRID equidistand points in INTERVAL." 9 | (loop for index below n-grid 10 | maximizing (funcall f 11 | (interval-midpoint interval 12 | (/ index (1- n-grid)))))) 13 | 14 | (defun approximation-error (f f-approx interval &optional (n-grid 1000)) 15 | "Approximation error, using MAXIMUM-ON-GRID." 16 | (maximum-on-grid (lambda (x) 17 | (abs-diff (funcall f x) (funcall f-approx x))) 18 | interval n-grid)) 19 | 20 | (defun test-chebyshev-approximate (f interval n-polynomials test-interval 21 | &rest rest) 22 | (let ((f-approx (apply #'chebyshev-approximate f interval n-polynomials rest))) 23 | (approximation-error f f-approx test-interval))) 24 | 25 | (deftest chebyshev-open-inf (chebyshev-tests) 26 | (assert-true (<= (test-chebyshev-approximate (lambda (x) (/ x (+ 4 x))) 27 | (interval 2 :plusinf) 15 28 | (interval 2 102)) 29 | 1e-5)) 30 | (assert-true (<= (test-chebyshev-approximate (lambda (x) (exp (- x))) 31 | (interval 0 :plusinf) 15 32 | (interval 0 10) 33 | :n-points 30) 34 | 1e-4))) 35 | 36 | (deftest chebyshev-finite-interval (chebyshev-tests) 37 | (assert-true (<= (test-chebyshev-approximate (lambda (x) (/ (1+ (expt x 2)))) 38 | (interval -3d0 2d0) 20 39 | (interval -1.5d0 1d0)) 40 | 1e-3))) 41 | -------------------------------------------------------------------------------- /tests/num=.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defsuite num=-tests (tests)) 6 | 7 | (deftest num=-number-test (num=-tests) 8 | (let ((*num=-tolerance* 1e-3)) 9 | (assert-equality #'num= 1 1) 10 | (assert-equality #'num= 1 1.0) 11 | (assert-equality #'num= 1 1.001) 12 | (assert-false (num= 1 2)) 13 | (assert-false (num= 1 1.01)))) 14 | 15 | (deftest num=-list-test (num=-tests) 16 | (let ((*num=-tolerance* 1e-3)) 17 | (assert-equality #'num= nil nil) 18 | (assert-equality #'num= '(1) '(1.001)) 19 | (assert-equality #'num= '(1 2) '(1.001 1.999)) 20 | (assert-false (num= '(0 1) '(0 1.02))) 21 | (assert-false (num= nil '(1))))) 22 | 23 | (deftest num=-array-test (num=-tests) 24 | (let* ((*num=-tolerance* 1e-3) 25 | (a #(0 1 2)) 26 | (b #2A((0 1) 27 | (2 3)))) 28 | (assert-equality #'num= a a) 29 | (assert-equality #'num= a #(0 1.001 2)) 30 | (assert-equality #'num= a #(0 1.001 2.001)) 31 | (assert-equality #'num= b b) 32 | (assert-equality #'num= b #2A((0 1) 33 | (2.001 3))) 34 | (assert-false (num= a b)) 35 | (assert-false (num= a #(0 1))) 36 | (assert-false (num= a #(0 1.01 2))) 37 | (assert-false (num= b #2A((0 1)))) 38 | (assert-false (num= b #2A((0 1.01) 39 | (2 3)))))) 40 | 41 | (defstruct num=-test-struct 42 | "Structure for testing DEFINE-STRUCTURE-num=." 43 | a b) 44 | 45 | (define-structure-num= num=-test-struct a b) 46 | 47 | (deftest num=-structure-test (num=-tests) 48 | (let ((*num=-tolerance* 1e-3) 49 | (a (make-num=-test-struct :a 0 :b 1)) 50 | (b (make-num=-test-struct :a "string" :b nil))) 51 | (assert-equality #'num= a a) 52 | (assert-equality #'num= a (make-num=-test-struct :a 0 :b 1)) 53 | (assert-equality #'num= a (make-num=-test-struct :a 0 :b 1.001)) 54 | (assert-false (num= a (make-num=-test-struct :a 0 :b 1.01))) 55 | (assert-equality #'num= b b) 56 | (assert-false (num= a b)))) 57 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 11 | system. Unless set, elements are left at their initial value. If 12 | initial-value is a function, it is called with the subscripts to initialize 13 | the elements.")) 14 | 15 | (defun sparse-array-extend-limits (limits subscripts) 16 | "Extend limits to incorporate subscripts. Does error checking on the length 17 | of subscripts." 18 | (let ((rank (length limits))) 19 | (assert (= rank (length subscripts))) 20 | (loop :for index :below rank 21 | :for subscript :in subscripts 22 | :do (check-type subscript fixnum) 23 | (aif (aref limits index) 24 | (progn 25 | (minf (car it) subscript) 26 | (maxf (cdr it) (1+ subscript))) 27 | (setf (aref limits index) (cons subscript (1+ subscript))))))) 28 | 29 | (defun sparse-array-initial-value (initial-value subscripts) 30 | "Initial value semantics for sparse arrays -- functions are called with 31 | subscripts." 32 | (if (functionp initial-value) 33 | (apply initial-value subscripts) 34 | initial-value)) 35 | 36 | (defmethod initialize-instance :after ((sparse-array sparse-array) 37 | &key rank &allow-other-keys) 38 | (check-type rank (integer 0)) 39 | (setf (limits sparse-array) (make-array rank :initial-element nil))) 40 | 41 | (defmethod ref ((sparse-array sparse-array) &rest subscripts) 42 | (let+ (((&slots-r/o elements initial-value) sparse-array) 43 | ((&values value present?) (gethash subscripts elements))) 44 | (if present? 45 | value 46 | (sparse-array-initial-value initial-value subscripts)))) 47 | 48 | (defmethod (setf ref) (value (sparse-array sparse-array) &rest subscripts) 49 | (sparse-array-extend-limits (limits sparse-array) subscripts) 50 | (setf (gethash subscripts (elements sparse-array)) value)) 51 | -------------------------------------------------------------------------------- /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 7 | is used, not the value). For complex numbers, return the epsilon of 8 | the corresponding real type, for rationals, the epsilon is that of a 9 | single float." 10 | (etypecase number 11 | (short-float short-float-epsilon) 12 | (single-float single-float-epsilon) 13 | (double-float double-float-epsilon) 14 | (long-float long-float-epsilon) 15 | (rational single-float-epsilon) 16 | (complex (real-epsilon (realpart number))))) 17 | 18 | (defparameter *default-min-step-correction* 100 19 | "Default multiplier for correcting the machine epsilon.") 20 | 21 | (defun default-min-step (width) 22 | "Default minimum step." 23 | (* *default-min-step-correction* (real-epsilon width))) 24 | 25 | (defparameter *pretty-bias* 0d0 26 | "Default bias for PRETTY-STEP.") 27 | 28 | (defparameter *pretty-five-bias* 0.1d0 29 | "Default bias to 5's for PRETTY-STEP.") 30 | 31 | (defun pretty (x &key (bias *pretty-bias*) (five-bias *pretty-five-bias*)) 32 | "Return a rational that is close to x, and is a multiple of 1,2 or 5 times a 33 | power of 10. The logarithm is taken, to which BIAS is added. The result will 34 | be based on the fractional part. FIVE-BIAS, also interpreted on a log scale, 35 | favors 5 over 2 as the first digit. When BIAS favors larger values." 36 | (let+ (((&values exponent residual) 37 | (floor (+ (coerce (log x 10) 'double-float) bias))) 38 | (correction (cond 39 | ((<= residual (- #.(log 2d0 10) five-bias)) 2) 40 | ((<= residual #.(log 5d0 10)) 5) 41 | (t 10)))) 42 | (values (* correction (expt 10 exponent)) 43 | (max 0 (- (if (= correction 10) -1 0) exponent))))) 44 | 45 | (defun pretty-step (width n &key 46 | (min-step (default-min-step width)) 47 | (bias *pretty-bias*) (five-bias *pretty-five-bias*)) 48 | "Return a `pretty' (meaning 1, 2, or 5*10^n) step size, and the number of 49 | fractional digits as the second value. Uses PRETTY, but enforces a minimum. 50 | When BIAS is 0,, STEP always divides WIDTH to at most N intervals." 51 | (pretty (max (/ width (1+ n)) min-step) :bias bias :five-bias five-bias)) 52 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/interval.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defsuite interval-tests (tests)) 6 | 7 | (deftest test-interval (interval-tests) 8 | (let ((a (interval 1 2))) 9 | (assert-equality #'num= 1 (interval-length a)) 10 | (assert-equality #'num= 1.25 (interval-midpoint a 0.25)) 11 | (assert-equality #'num= (interval 1.25 1.8) (shrink-interval a 0.25 0.2)) 12 | (assert-true (in-interval? a 1.5)) 13 | (assert-true (in-interval? a 1)) 14 | (assert-true (in-interval? a 2)) 15 | (assert-false (in-interval? a 0.9)) 16 | (assert-false (in-interval? a 2.1)) 17 | (assert-condition error (interval 2 1)))) 18 | 19 | (deftest test-interval-hull (interval-tests) 20 | (let ((a (interval 1 2))) 21 | (assert-equality #'num= nil (interval-hull nil)) 22 | (assert-equality #'num= a (interval-hull a)) 23 | (assert-equality #'num= a (interval-hull '(1 1.5 2))) 24 | (assert-equality #'num= a (interval-hull #(1 1.5 2))) 25 | (assert-equality #'num= a (interval-hull #2A((1) (1.5) (2)))) 26 | (assert-equality #'num= (interval -1 3) 27 | (interval-hull (list (interval 0 2) -1 #(3) '(2.5)))) 28 | (assert-condition error (interval-hull #C(1 2))))) 29 | 30 | (deftest test-split-interval (interval-tests) 31 | (let ((a (interval 10 20))) 32 | (assert-equality #'num= (vector (interval 10 13) (interval 13 14) (interval 14 20)) 33 | (split-interval a (list (spacer 1) (relative 0.1) (spacer 2)))) 34 | (assert-equality #'num= (vector (interval 10 16) (interval 16 20)) 35 | (split-interval a (list (spacer) 4))) 36 | (assert-condition error (split-interval a (list 9))) 37 | (assert-condition error (split-interval a (list 6 7 (spacer)))))) 38 | 39 | (deftest test-extendf-interval (interval-tests) 40 | (let+ ((counter -1) 41 | (a (make-array 2 :initial-contents (list nil (interval 1 2))))) 42 | (extendf-interval (aref a (incf counter)) 3) 43 | (extendf-interval (aref a (incf counter)) 3) 44 | (assert-equality #'num= (vector (interval 3 3) (interval 1 3)) a) 45 | (assert-equality #'num= 1 counter))) 46 | 47 | (deftest test-grid-in (interval-tests) 48 | (let ((*lift-equality-test* #'array=)) 49 | (assert-equality #'num= #(0.0 0.5 1.0) (grid-in (interval 0.0 1.0) 3)) 50 | (assert-equality #'num= #(0 2 4) (grid-in (interval 0 4) 3)))) 51 | 52 | (deftest test-subintervals-in (interval-tests) 53 | (let ((expected (vector (interval 0 1 :open-left? nil :open-right? t) 54 | (interval 1 2 :open-left? nil :open-right? t) 55 | (interval 2 3 :open-left? nil :open-right? nil)))) 56 | (assert-equality #'num= (subintervals-in (interval 0 3) 3) 57 | expected))) 58 | 59 | (deftest test-plusminus-interval (interval-tests) 60 | (assert-equality #'num= (interval 0.5 1.5) (plusminus-interval 1 0.5))) 61 | -------------------------------------------------------------------------------- /src/num=.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (defpackage #:cl-num-utils.num= 4 | (:use #:cl 5 | #:alexandria 6 | #:anaphora 7 | #:let-plus) 8 | (:export 9 | #:num-delta 10 | #:*num=-tolerance* 11 | #:num= 12 | #:num=-function 13 | #:define-num=-with-accessors 14 | #:define-structure-num=)) 15 | 16 | (in-package #:cl-num-utils.num=) 17 | 18 | (defparameter *num=-tolerance* 1d-5 "Default tolerance for NUM=.") 19 | 20 | (defun num-delta (a b) 21 | "|a-b|/max(1,|a|,|b|). Useful for comparing numbers." 22 | (/ (abs (- a b)) 23 | (max 1 (abs a) (abs b)))) 24 | 25 | (defgeneric num= (a b &optional tolerance) 26 | (:documentation "Compare A and B for approximate equality, checking corresponding elements when applicable (using TOLERANCE). 27 | 28 | Two numbers A and B are NUM= iff |a-b|/max(1,|a|,|b|) <= tolerance. 29 | 30 | Unless a method is defined for them, two objects are compared with EQUALP. 31 | 32 | Generally, methods should be defined so that two objects are NUM= if they the same class, same dimensions, and all their elements are NUM=.") 33 | (:method (a b &optional (tolerance *num=-tolerance*)) 34 | (declare (ignore tolerance)) 35 | (equalp a b)) 36 | (:method ((a number) (b number) &optional (tolerance *num=-tolerance*)) 37 | (<= (abs (- a b)) (* (max 1 (abs a) (abs b)) tolerance))) 38 | (:method ((a array) (b array) &optional (tolerance *num=-tolerance*)) 39 | (and (equal (array-dimensions a) (array-dimensions b)) 40 | (loop 41 | for index :below (array-total-size a) 42 | always (num= (row-major-aref a index) 43 | (row-major-aref b index) 44 | tolerance)))) 45 | (:method ((a cons) (b cons) &optional (tolerance *num=-tolerance*)) 46 | (and (num= (car a) (car b) tolerance) 47 | (num= (cdr a) (cdr b) tolerance))) 48 | (:method ((a null) (b null) &optional (tolerance *num=-tolerance*)) 49 | (declare (ignore tolerance)) 50 | t)) 51 | 52 | (defun num=-function (tolerance) 53 | "Curried version of num=, with given tolerance." 54 | (lambda (a b) 55 | (num= a b tolerance))) 56 | 57 | (defmacro define-num=-with-accessors (class accessors) 58 | "Define a method for NUM=, specialized to the given class, comparing values obtained with accessors." 59 | `(defmethod num= ((a ,class) (b ,class) 60 | &optional (tolerance *num=-tolerance*)) 61 | (and ,@(loop for accessor in accessors 62 | collect `(num= (,accessor a) (,accessor b) tolerance))))) 63 | 64 | (defmacro define-structure-num= (structure &rest slots) 65 | "Define a NUM= method for the given structure, comparing the given slots." 66 | (check-type structure symbol) 67 | `(define-num=-with-accessors ,structure 68 | ,(loop for slot in slots 69 | collect (symbolicate structure "-" slot)))) 70 | -------------------------------------------------------------------------------- /tests/matrix.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defsuite matrix-suite (tests)) 6 | 7 | (deftest wrapped-univariate-operation (matrix-suite) 8 | (assert-equality #'num= (e- (upper-triangular-mx t 2)) (upper-triangular-mx t -2)) 9 | (assert-equality #'num= (e/ (upper-triangular-mx t 2)) (upper-triangular-mx t 0.5)) 10 | (assert-equality #'num= (e+ (upper-triangular-mx t 2)) (upper-triangular-mx t 2))) 11 | 12 | (defun do-matrix-convert-ops (test converts &key (ops (list #'e+ #'e- #'e*))) 13 | "Funcall TEST with CONVERT and each operation in OPs." 14 | (mapc (lambda (convert) 15 | (mapc (curry #'funcall test convert) ops)) 16 | converts)) 17 | 18 | (defun assert-distributive-convert-op (a b convert op) 19 | "Check that OP distributes over CONVERT." 20 | (assert-equality #'num= (funcall convert (funcall op a b)) 21 | (funcall op (funcall convert a) (funcall convert b)))) 22 | 23 | (deftest wrapped-bivariate-operation (matrix-suite) 24 | (do-matrix-convert-ops (curry #'assert-distributive-convert-op 25 | (mx t 26 | (1 2) 27 | (3 4)) 28 | (mx t 29 | (5 7) 30 | (11 13))) 31 | (list #'hermitian-matrix 32 | #'lower-triangular-matrix 33 | #'upper-triangular-matrix))) 34 | 35 | (deftest wrapped-bivariate-to-array (matrix-suite) 36 | (let+ ((a (mx t 37 | (1 2) 38 | (3 4))) 39 | (b (mx t 40 | (5 7) 41 | (11 13)))) 42 | (do-matrix-convert-ops (lambda (convert op) 43 | (assert-equality #'num= (funcall op a b) 44 | (funcall op (funcall convert a) b)) 45 | (assert-equality #'num= (funcall op a b) 46 | (funcall op a (funcall convert b)))) 47 | (list #'hermitian-matrix 48 | #'lower-triangular-matrix 49 | #'upper-triangular-matrix)))) 50 | 51 | (deftest diagonal-test (matrix-suite) 52 | (do-matrix-convert-ops (curry #'assert-distributive-convert-op 53 | (vec t 1 2 3 4) 54 | (vec t 5 7 11 13)) 55 | (list #'diagonal-matrix))) 56 | 57 | (deftest wrapped-matrix-slice (matrix-suite) 58 | (let+ ((mx (mx t 59 | (1 2 3) 60 | (4 5 6) 61 | (7 8 9))) 62 | ((¯olet assert-slice (type) 63 | (check-type type symbol) 64 | `(let* ((wrapped (,type mx)) 65 | (slice (cons 0 2)) 66 | (sliced (slice wrapped slice))) 67 | (assert-eq ',type (type-of sliced)) 68 | (assert-equality #'num= sliced (,type (slice mx slice slice))))))) 69 | (assert-slice upper-triangular-matrix) 70 | (assert-slice lower-triangular-matrix) 71 | (assert-slice hermitian-matrix))) 72 | -------------------------------------------------------------------------------- /tests/matrix-shorthand.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defsuite matrix-shorthand-suite (tests)) 6 | 7 | (deftest lower-triangular-shorthand-test (matrix-shorthand-suite) 8 | (let ((matrix #2A((1 2) 9 | (3 4))) 10 | (lower-triangular-mx (lower-triangular-mx t 11 | (1) 12 | (3 4)))) 13 | (assert-equality #'num= (lower-triangular-matrix matrix) lower-triangular-mx) 14 | (assert-equality #'num= lower-triangular-mx (lower-triangular-mx t 15 | (1 9) ; 9 should be ignored 16 | (3 4))) 17 | (assert-equality #'num= (lower-triangular-mx t 18 | (1 2 3) 19 | (3 4 5)) 20 | (lower-triangular-mx t 21 | (1 2 17) 22 | (3 4 5))) 23 | (assert-equality #'num= (lower-triangular-mx t 24 | (1 2) 25 | (3 4) 26 | (5 6)) 27 | (lower-triangular-mx t 28 | (1 19) 29 | (3 4) 30 | (5 6))))) 31 | 32 | (deftest upper-triangular-shorthand-test (matrix-shorthand-suite) 33 | (let ((matrix #2A((1 2) 34 | (3 4))) 35 | (upper-triangular-mx (upper-triangular-mx t 36 | (1 2) 37 | (3 4)))) 38 | (assert-equality #'num= (upper-triangular-matrix matrix) upper-triangular-mx) 39 | (assert-equality #'num= upper-triangular-mx (upper-triangular-mx t 40 | (1 2) 41 | (9 4))) ; 9 should be ignored 42 | (assert-equality #'num= (upper-triangular-mx t 43 | (1 2 3) 44 | (3 4 5)) 45 | (upper-triangular-mx t 46 | (1 2 3) 47 | (19 4 5))) 48 | (assert-equality #'num= (upper-triangular-mx t 49 | (1 2) 50 | (3 4) 51 | (5 6)) 52 | (upper-triangular-mx t 53 | (1 2) 54 | (3 4) 55 | (19 6))))) 56 | 57 | (deftest hermitian-shorthand-test (matrix-shorthand-suite) 58 | (let ((matrix #2A((1 2) 59 | (3 4))) 60 | (hermitian-mx (hermitian-mx t 61 | (1) 62 | (3 4)))) 63 | (assert-equality #'num= hermitian-mx (hermitian-matrix matrix)) 64 | (assert-equality #'num= hermitian-mx (hermitian-mx t 65 | (1 9) ; 9 should be ignored 66 | (3 4))) 67 | (assert-condition error (hermitian-mx t 68 | (1 2 3) 69 | (3 4 5))))) 70 | 71 | (deftest diagonal-shorthand-test (matrix-shorthand-suite) 72 | (assert-equality #'num= (diagonal-mx t 1 2 3) (diagonal-matrix #(1 2 3)))) 73 | 74 | (deftest vec-shorthand-test (matrix-shorthand-suite) 75 | (assert-equality #'num= (vec t 1 2 3) #(1 2 3))) 76 | -------------------------------------------------------------------------------- /tests/arithmetic.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defsuite arithmetic-tests (tests)) 6 | 7 | (deftest arithmetic-functions (arithmetic-tests) 8 | (assert-true (same-sign? 1 2 3)) 9 | (assert-false (same-sign? 1 -2 3)) 10 | (assert-eql 4 (square 2)) 11 | (assert-eql 4.0 (absolute-square 2.0)) 12 | (assert-eql 25 (absolute-square #C(3 4))) 13 | (assert-eql 2 (abs-diff 3 5)) 14 | (assert-eql 2 (abs-diff -3 -5)) 15 | (assert-equality #'num= 2 (log10 100)) 16 | (assert-equality #'num= 8 (log2 256)) 17 | (assert-eql 1/5 (1c 4/5)) 18 | (assert-true (divides? 8 2)) 19 | (assert-false (divides? 8 3)) 20 | (assert-eql 2 (as-integer 2.0)) 21 | (assert-condition error (as-integer 2.5))) 22 | 23 | (deftest arithmetic-sequences (arithmetic-tests) 24 | (assert-equalp #(2 3 4) (numseq 2 4)) 25 | (assert-equalp #(2 4 6 8) (numseq 2 nil :length 4 :by 2)) 26 | (assert-equalp #(0 1 2 3) (ivec 4)) 27 | (assert-equalp #(1 2 3) (ivec 1 4)) 28 | (assert-equalp #(1 3) (ivec 1 4 2)) 29 | (assert-condition error #(1 3) (ivec 4 1 1 t))) 30 | 31 | (deftest arithmetic-summaries (arithmetic-tests) 32 | (let ((v #(2 3 4))) 33 | (assert-eql 9 (sum v)) 34 | (assert-eql 24 (product v)) 35 | (assert-equalp #(2 5 9) (cumulative-sum v)) 36 | (assert-equalp #(2 6 24) (cumulative-product v)) 37 | (assert-eql 0 (sum #())) 38 | (assert-eql 1 (product #())) 39 | (assert-equalp #() (cumulative-sum #())) 40 | (assert-equalp #() (cumulative-product #())))) 41 | 42 | (deftest norms (arithmetic-tests) 43 | (let* ((a #(2 3 4)) 44 | (a-list (coerce a 'list)) 45 | (b #(#C(3 4) 0 5 5 5)) 46 | (b-list (coerce b 'list))) 47 | (assert-equality #'num= (sqrt 29) (l2norm a)) 48 | (assert-equality #'num= (sqrt 29) (l2norm a-list)) 49 | (assert-equality #'num= 10 (l2norm b)) 50 | (assert-equality #'num= 10 (l2norm b-list)))) 51 | 52 | (deftest normalize-probabilities (arithmetic-tests) 53 | (let* ((a (vector 1 2 7)) 54 | (a-copy (copy-seq a))) 55 | (assert-equalp #(1/10 2/10 7/10) (normalize-probabilities a)) 56 | (assert-equalp a a-copy) ; not modified 57 | (assert-equalp #(0.1d0 0.2d0 0.7d0) 58 | (normalize-probabilities a :element-type 'double-float)) 59 | (assert-equalp a a-copy) ; not modified 60 | (assert-condition error (normalize-probabilities #(1 -1))) 61 | (let ((normalized #(0.1d0 0.2d0 0.7d0))) 62 | (assert-equalp normalized 63 | (normalize-probabilities a 64 | :element-type 'double-float 65 | :result nil)) 66 | (assert-equalp a normalized) 67 | (assert-false (equalp a a-copy))))) 68 | 69 | (deftest arithmetic-rounding (arithmetic-tests) 70 | (assert-equalp '(25 2) (multiple-value-list (floor* 27 5))) 71 | (assert-equalp '(26 1) (multiple-value-list (floor* 27 5 1))) 72 | (assert-equalp '(30 -3) (multiple-value-list (ceiling* 27 5))) 73 | (assert-equalp '(31 -4) (multiple-value-list (ceiling* 27 5 1))) 74 | (assert-equalp '(25 2) (multiple-value-list (round* 27 5))) 75 | (assert-equalp '(29 -2) (multiple-value-list (round* 27 5 -1))) 76 | (assert-equalp '(-25 -2) (multiple-value-list (truncate* -27 5))) 77 | (assert-equalp '(-24 -3) (multiple-value-list (truncate* -27 5 1)))) 78 | -------------------------------------------------------------------------------- /src/print-matrix.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (cl:defpackage #:cl-num-utils.print-matrix 4 | (:use #:cl 5 | #:alexandria 6 | #:anaphora 7 | #:let-plus) 8 | (:export 9 | #:print-length-truncate 10 | #:*print-matrix-precision* 11 | #:print-matrix)) 12 | 13 | (cl:in-package #:cl-num-utils.print-matrix) 14 | 15 | (defun print-length-truncate (dimension) 16 | "Return values (min dimension *print-length*) and whether the constraint is binding." 17 | (if (or (not *print-length*) (<= dimension *print-length*)) 18 | (values dimension nil) 19 | (values *print-length* t))) 20 | 21 | (defvar *print-matrix-precision* 5 22 | "Number of digits after the decimal point when printing numeric matrices.") 23 | 24 | (defun print-matrix-formatter (x) 25 | "Standard formatter for matrix printing. Respects *print-precision*, and formats complex numbers as a+bi, eg 0.0+1.0i." 26 | ;; ?? do we want a complex numbers to be aligned on the +, like R? I 27 | ;; am not sure I like that very much, and for a lot of data, I would 28 | ;; visualize it graphically anyhow (I hate tables of 7+ numbers in 29 | ;; general). -- Tamas, 2009-sep-13 30 | (let ((precision *print-matrix-precision*)) 31 | (typecase x 32 | (integer (format nil "~d" x)) 33 | (real (format nil "~,vf" precision x)) 34 | (complex (format nil "~,vf+~,vfi" 35 | precision (realpart x) 36 | precision (imagpart x))) 37 | (t (format nil "~a" x))))) 38 | 39 | (defun print-matrix (matrix stream 40 | &key (formatter #'print-matrix-formatter) 41 | (masked-fn (constantly nil)) 42 | (aligned? t) 43 | (padding " ") 44 | (indent " ")) 45 | "Format and print the elements of MATRIX (a 2d array) to STREAM, using PADDING between columns. 46 | 47 | 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. 48 | 49 | If ALIGNED?, columns will be right-aligned. At most *PRINT-LENGTH* rows and columns are printed, more is indicated with ellipses (...)." 50 | ;; QUESTION maybe column & row labels, not a high priority at the moment 51 | (let+ (((&values nrow row-trunc?) (print-length-truncate (aops:nrow matrix))) 52 | ((&values ncol col-trunc?) (print-length-truncate (aops:ncol matrix))) 53 | (formatted-elements (make-array (list nrow ncol))) 54 | (column-widths (make-array ncol :element-type 'fixnum :initial-element 0))) 55 | ;; first pass - format elements, measure width 56 | (dotimes (col ncol) 57 | (dotimes (row nrow) 58 | (let+ ((masked? (funcall masked-fn row col)) 59 | (formatted-element (aif masked? 60 | it 61 | (funcall formatter (aref matrix row col)))) 62 | (width (length formatted-element))) 63 | (maxf (aref column-widths col) width) 64 | (setf (aref formatted-elements row col) formatted-element)))) 65 | ;; second pass - print 66 | (dotimes (row nrow) 67 | (when (plusp row) 68 | (fresh-line stream)) 69 | (format stream indent) 70 | (dotimes (col ncol) 71 | (when (plusp col) 72 | (princ padding stream)) 73 | (let ((elt (aref formatted-elements row col))) 74 | (if aligned? 75 | (format stream "~V@A" (aref column-widths col) elt) 76 | (princ elt stream)))) 77 | (when col-trunc? 78 | (princ padding stream) 79 | (princ "..." stream))) 80 | (when row-trunc? 81 | (format stream "~&...")))) 82 | -------------------------------------------------------------------------------- /src/matrix-shorthand.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | (cl:defpackage #:cl-num-utils.matrix-shorthand 3 | (:nicknames #:clnu.mx) 4 | (:use #:cl 5 | #:alexandria 6 | #:anaphora 7 | #:cl-num-utils.matrix 8 | #:cl-num-utils.utilities 9 | #:let-plus) 10 | (:export 11 | #:vec 12 | #:mx 13 | #:diagonal-mx 14 | #:lower-triangular-mx 15 | #:hermitian-mx 16 | #:upper-triangular-mx)) 17 | 18 | (in-package #:cl-num-utils.matrix-shorthand) 19 | 20 | 21 | 22 | (defun vec (element-type &rest elements) 23 | "Return a vector with elements coerced to ELEMENT-TYPE." 24 | (map `(simple-array ,element-type (*)) 25 | (lambda (element) (coerce element element-type)) 26 | elements)) 27 | 28 | (defun diagonal-mx (element-type &rest elements) 29 | "Return a DIAGONAL-MATRIX with elements coerced to ELEMENT-TYPE." 30 | (diagonal-matrix (apply #'vec element-type elements))) 31 | 32 | (defmacro mx (element-type &body rows) 33 | "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." 34 | (let+ ((rows (map 'vector #'ensure-list rows)) 35 | (nrow (length rows)) 36 | (ncol (length (aref rows 0))) 37 | ((&once-only element-type))) 38 | `(make-array (list ,nrow ,ncol) 39 | :element-type ,element-type 40 | :initial-contents 41 | (list 42 | ,@(loop for row across rows collect 43 | `(list 44 | ,@(loop for element in row collect 45 | `(coerce ,element ,element-type)))))))) 46 | 47 | (defun pad-left-expansion (rows ncol) 48 | "Pad ragged-right rows. Used internally to implement ragged right matrix specifications." 49 | (loop for row in rows 50 | for row-index from 0 51 | collect (aprog1 (make-sequence 'list ncol :initial-element 0) 52 | (replace it row :start1 0 :end1 (min ncol (1+ row-index)))))) 53 | 54 | (defmacro lower-triangular-mx (element-type &body rows) 55 | "Macro for creating 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." 56 | `(lower-triangular-matrix 57 | (mx ,element-type 58 | ,@(pad-left-expansion (mapcar #'ensure-list rows) 59 | (reduce #'max rows :key #'length))))) 60 | 61 | (defmacro hermitian-mx (element-type &body rows) 62 | "Macro for creating 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." 63 | `(hermitian-matrix 64 | (mx ,element-type 65 | ,@(pad-left-expansion (mapcar #'ensure-list rows) 66 | (max (length rows) 67 | (reduce #'max rows :key #'length)))))) 68 | 69 | (defmacro upper-triangular-mx (element-type &body rows) 70 | "Macro for creating an upper triangular matrix. ROWS should be a list of lists, elements are evaluated. Masked elements (below the diagonal) are ignored at the expansion." 71 | `(upper-triangular-matrix 72 | (mx ,element-type 73 | ,@(loop for row-index from 0 74 | for row in rows 75 | collect (loop for column-index from 0 76 | for element in (ensure-list row) 77 | collect (if (< column-index row-index) 78 | 0 79 | element)))))) 80 | -------------------------------------------------------------------------------- /tests/elementwise.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defsuite elementwise-tests (tests)) 6 | 7 | (deftest elementwise-float-contagion (elementwise-tests) 8 | (flet ((compare (type &rest objects) 9 | (type= (apply #'cl-num-utils.elementwise::elementwise-float-contagion 10 | objects) type))) 11 | (assert-true (compare 'double-float 1d0) 0) 12 | (assert-true (compare 'real 0 1)))) 13 | 14 | (deftest e-operations-tests (elementwise-tests) 15 | (let+ (((&flet arr (dimensions element-type &rest elements) 16 | (aprog1 (make-array dimensions :element-type element-type) 17 | (assert (length= elements (array-total-size it))) 18 | (loop for index from 0 19 | for element in elements 20 | do (setf (row-major-aref it index) 21 | (coerce element element-type)))))) 22 | (a (arr '(2 3) 'double-float 23 | 1 2 3 24 | 4 5 6)) 25 | (b (arr '(2 3) 'single-float 26 | 2 3 5 27 | 7 11 13))) 28 | (assert-equalp (e+ a b) (arr '(2 3) 'double-float 29 | 3 5 8 30 | 11 16 19)) 31 | (assert-equalp (e* a 2s0) (arr '(2 3) 'double-float 32 | 2 4 6 33 | 8 10 12)) 34 | (assert-equalp (e+ a 2 b) (e+ (e+ a b) 2)) 35 | (assert-equalp (e+ a a) (e* a 2)) 36 | ;; (ensure-error (e/ a 0)) ; division by 0 37 | (assert-condition error (e+ a ; dimension incompatibility 38 | (arr '(1 1) 'double-float 2))) 39 | (assert-equalp (e+ a) (e+ a 0)) 40 | (assert-equalp (e* a) (e* a 1)) 41 | (assert-equalp (e- a) (e- 0d0 a)) 42 | (assert-equalp (e/ a) (e/ 1d0 a)) 43 | (assert-equality #'num= #(1.0) (elog #(10) 10)) 44 | (assert-equality #'num= a (eexp (elog a))))) 45 | 46 | ;; (deftest (elementwise-tests) 47 | ;; stack-tests 48 | ;; (let ((a (array* '(2 3) t 49 | ;; 1 2 3 50 | ;; 4 5 6)) 51 | ;; (b (array* '(2 2) t 52 | ;; 3 5 53 | ;; 7 9)) 54 | ;; (*lift-equality-test* #'equalp)) 55 | ;; (assert-equalp (stack 'double-float :h a b) 56 | ;; (array* '(2 5) 'double-float 57 | ;; 1 2 3 3 5 58 | ;; 4 5 6 7 9)) 59 | ;; (assert-equalp (stack t :v (transpose a) b) 60 | ;; #2A((1 4) 61 | ;; (2 5) 62 | ;; (3 6) 63 | ;; (3 5) 64 | ;; (7 9))) 65 | ;; (assert-equalp (stack 'fixnum :v a #(7 8 9) 10) 66 | ;; (array* '(4 3) 'fixnum 67 | ;; 1 2 3 68 | ;; 4 5 6 69 | ;; 7 8 9 70 | ;; 10 10 10)) 71 | ;; (assert-equalp (stack t :h b #(1 2) b 9 b) 72 | ;; (array* '(2 8) t 73 | ;; 3 5 1 3 5 9 3 5 74 | ;; 7 9 2 7 9 9 7 9)) 75 | ;; (assert-equalp (stack t :h 76 | ;; (vector* 'double-float 1d0 2d0) 77 | ;; (vector* 'double-float 3d0 4d0)) 78 | ;; (array* '(2 2) 'double-float 79 | ;; 1 3 80 | ;; 2 4)) 81 | ;; (assert-equalp (stack 'double-float :h 1.0d0 #()) ; empty array 82 | ;; (array* '(0 2) 'double-float)))) 83 | 84 | ;; (deftest (elementwise-tests) 85 | ;; concat-test 86 | ;; (assert-equalp (concat t #(1 2 3) #(4 5 6) (list 7) '(8 9 10)) 87 | ;; (numseq 1 10 :type t) :test #'equalp)) 88 | -------------------------------------------------------------------------------- /src/extended-real.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (defpackage #:cl-num-utils.extended-real 4 | (:use #:cl #:alexandria) 5 | (:nicknames #:xreal) 6 | (:shadow #:= #:< #:> #:<= #:>=) 7 | (:export 8 | :infinite? 9 | :extended-real 10 | := 11 | :< 12 | :> 13 | :<= 14 | :>= 15 | :with-template 16 | :lambda-template)) 17 | 18 | (in-package #:cl-num-utils.extended-real) 19 | 20 | (deftype infinite () 21 | "Representing infinity (extending the real line)." 22 | '(member :plusinf :minusinf)) 23 | 24 | (defun infinite? (object) 25 | "Test if an object represents positive or negative infinity." 26 | (typep object 'infinite)) 27 | 28 | (deftype extended-real (&optional (base 'real)) 29 | "Extended real number." 30 | `(or infinite ,base)) 31 | 32 | (defun extend-pairwise-comparison (test first rest) 33 | "Extend TEST (a pairwise comparison) to an arbitrary number of arguments (but at least one, FIRST)." 34 | (loop while rest do 35 | (let ((next (car rest))) 36 | (unless (funcall test first next) 37 | (return-from extend-pairwise-comparison nil)) 38 | (setf first next 39 | rest (cdr rest)))) 40 | t) 41 | 42 | (defmacro with-template ((prefix &rest variables) &body body) 43 | "Define the function (PREFIX &rest VARIABLES) which can be used to match variables using :PLUSINF, :MINUSINF, REAL, or T." 44 | (let ((names (mapcar (curry #'symbolicate 'kind-) variables))) 45 | `(macrolet ((,prefix ,names 46 | (flet ((expand (kind variable) 47 | (ecase kind 48 | (:plusinf `(eq :plusinf ,variable)) 49 | (:minusinf `(eq :minusinf ,variable)) 50 | (real `(realp ,variable)) 51 | ((t) t)))) 52 | (list 'and 53 | ,@(mapcar (lambda (name variable) 54 | `(expand ,name ',variable)) 55 | names variables))))) 56 | ,@(loop for v in variables 57 | collect `(check-type ,v extended-real)) 58 | ,@body))) 59 | 60 | (defmacro lambda-template ((prefix &rest variables) &body body) 61 | "LAMBDA with WITH-TEMPLATE in its BODY." 62 | `(lambda ,variables 63 | (with-template (,prefix ,@variables) 64 | ,@body))) 65 | 66 | (defmacro define-comparison (name test) 67 | "Define a comparison, extendeding a pairwise comparison to an arbitrary number of arguments." 68 | `(defun ,name (number &rest more-numbers) 69 | (extend-pairwise-comparison ,test number more-numbers))) 70 | 71 | (define-comparison = 72 | (lambda-template (? a b) 73 | (if (? real real) 74 | (cl:= a b) 75 | (or (? :plusinf :plusinf) 76 | (? :minusinf :minusinf))))) 77 | 78 | (define-comparison < 79 | (lambda-template (? a b) 80 | (if (? real real) 81 | (cl:< a b) 82 | (or (? :minusinf :plusinf) 83 | (? :minusinf real) 84 | (? real :plusinf))))) 85 | 86 | (define-comparison > 87 | (lambda-template (? a b) 88 | (if (? real real) 89 | (cl:> a b) 90 | (or (? :plusinf :minusinf) 91 | (? real :minusinf) 92 | (? :plusinf real))))) 93 | 94 | (define-comparison <= 95 | (lambda-template (? a b) 96 | (if (? real real) 97 | (cl:<= a b) 98 | (or (? :minusinf t) 99 | (? t :plusinf))))) 100 | 101 | (define-comparison >= 102 | (lambda-template (? a b) 103 | (if (? real real) 104 | (cl:>= a b) 105 | (or (? t :minusinf) 106 | (? :plusinf t))))) 107 | 108 | ;;; TODO /=, min, max, minusp, plusp, abs, ... 109 | -------------------------------------------------------------------------------- /tests/extended-real.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-num-utils-tests) 2 | 3 | (defsuite extended-real-tests (tests)) 4 | 5 | ;;; helper macros for defining tests 6 | 7 | (defun assert-relation (relation &rest argument-lists) 8 | "Assert RELATION called with each set of arguments." 9 | (loop for a in argument-lists 10 | do (assert-true (apply relation a)))) 11 | 12 | (defun assert-not-relation (relation &rest argument-lists) 13 | "Assert that RELATION does not hold, called with each set of arguments." 14 | (loop for a in argument-lists 15 | do (assert-false (apply relation a)))) 16 | 17 | (defun assert-paired-relation (relation1 relation2 &rest argument-lists) 18 | (apply #'assert-relation relation1 argument-lists) 19 | (apply #'assert-relation relation2 (mapcar #'reverse argument-lists))) 20 | 21 | (defun assert-not-paired-relation (relation1 relation2 &rest argument-lists) 22 | (apply #'assert-not-relation relation1 argument-lists) 23 | (apply #'assert-not-relation relation2 (mapcar #'reverse argument-lists))) 24 | 25 | (defun assert-relation-corner-cases (&rest relations) 26 | (loop for r in relations 27 | do (assert-true (funcall r 1)) 28 | (assert-true (funcall r :plusinf)) 29 | (assert-true (funcall r :minusinf)) 30 | (assert-condition error (funcall r)))) 31 | 32 | (deftest relation-corner-cases-test (extended-real-tests) 33 | (assert-relation-corner-cases #'xreal:= #'xreal:< #'xreal:> #'xreal:>= #'xreal:<=)) 34 | 35 | (deftest strict-inequalities-test (extended-real-tests) 36 | (assert-paired-relation #'xreal:< #'xreal:> 37 | ;; < pairs 38 | '(1 2) 39 | '(1 :plusinf) 40 | '(:minusinf :plusinf) 41 | '(:minusinf 1) 42 | ;; < sequences 43 | '(1 2 3) 44 | '(1 2 :plusinf) 45 | '(:minusinf 1 4 :plusinf)) 46 | (assert-not-paired-relation #'xreal:< #'xreal:> 47 | ;; not < pairs 48 | '(1 1) 49 | '(2 1) 50 | '(:plusinf :plusinf) 51 | '(:plusinf 1) 52 | '(:minusinf :minusinf) 53 | '(:plusinf :minusinf) 54 | '(1 :minusinf) 55 | ;; not < sequences 56 | '(1 2 2) 57 | '(1 3 2) 58 | '(1 :plusinf 2) 59 | '(1 :plusinf :plusinf))) 60 | 61 | (deftest inequalities-test (extended-real-tests) 62 | (assert-paired-relation #'xreal:<= #'xreal:>= 63 | ;; <= pairs 64 | '(1 1) 65 | '(1 2) 66 | '(1 :plusinf) 67 | '(:plusinf :plusinf) 68 | '(:minusinf :plusinf) 69 | '(:minusinf :minusinf) 70 | '(:minusinf 1) 71 | ;; < sequences 72 | '(1 2 2) 73 | '(1 2 3) 74 | '(1 2 :plusinf) 75 | '(1 :plusinf :plusinf) 76 | '(:minusinf 1 4 :plusinf)) 77 | (assert-not-paired-relation #'xreal:<= #'xreal:>= 78 | ;; not < pairs 79 | '(2 1) 80 | '(:plusinf 1) 81 | '(:plusinf :minusinf) 82 | '(1 :minusinf) 83 | ;; not <=/>= sequences 84 | '(1 3 2) 85 | '(1 :plusinf 2))) 86 | 87 | (deftest equality-test (extended-real-tests) 88 | (assert-relation #'xreal:= 89 | ;; = pairs 90 | '(1 1) 91 | '(:plusinf :plusinf) 92 | '(:minusinf :minusinf) 93 | ;; = sequences 94 | '(2 2 2) 95 | '(:plusinf :plusinf :plusinf) 96 | '(:minusinf :minusinf :minusinf)) 97 | (assert-not-relation #'xreal:= 98 | ;; not = pairs 99 | '(1 2) 100 | '(2 1) 101 | '(1 :plusinf) 102 | '(:plusinf 1) 103 | '(1 :minusinf) 104 | '(:minusinf 1) 105 | ;; not = sequences 106 | '(1 2 2) 107 | '(2 2 1) 108 | '(:plusinf :plusinf 9) 109 | '(:plusinf :minusinf))) 110 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/chebyshev.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | (defpackage #:cl-num-utils.chebyshev 3 | (:use #:cl 4 | #:alexandria 5 | #:anaphora 6 | #:cl-num-utils.interval 7 | #:cl-num-utils.utilities 8 | #:let-plus) 9 | (:export 10 | #:chebyshev-root 11 | #:chebyshev-roots 12 | #:chebyshev-regression 13 | #:chebyshev-evaluate 14 | #:chebyshev-approximate)) 15 | 16 | (in-package #:cl-num-utils.chebyshev) 17 | 18 | (declaim (inline chebyshev-recursion)) 19 | (defun chebyshev-recursion (x value previous-value) 20 | "Chebyshev polynomial recursion formula." 21 | (- (* 2 x value) previous-value)) 22 | 23 | (declaim (inline chebyshev-root)) 24 | (defun chebyshev-root (m i) 25 | "Return the iTH root of the Mth Chebyshev polynomial as double-float." 26 | (assert (within? 0 i m)) 27 | (- (cos (/ (* (+ i 1/2) (float pi 1d0)) m)))) 28 | 29 | (defun chebyshev-roots (m) 30 | "Return the roots of the Mth Chebyshev polynomial as a vector of 31 | double-floats." 32 | (aprog1 (make-array m :element-type 'double-float) 33 | (dotimes (i m) 34 | (setf (aref it i) (chebyshev-root m i))))) 35 | 36 | (defun chebyshev-regression (f n-polynomials 37 | &optional (n-points n-polynomials)) 38 | "Chebyshev polynomial regression using the given number of polynomials and 39 | points (zeroes of the corresponding Chebyshev polynomial)." 40 | (check-types (n-polynomials n-points) positive-fixnum) 41 | (assert (<= n-polynomials n-points) () 42 | "Can't identify ~A coefficients with only ~A points." 43 | n-polynomials n-points) 44 | (locally (declare ; (optimize speed) 45 | (type positive-fixnum n-polynomials n-points)) 46 | (let+ ((z (the simple-double-float-vector (chebyshev-roots n-points))) 47 | (f-at-z (map 'simple-double-float-vector 48 | (lambda (z) (coerce (funcall f z) 'double-float)) z)) 49 | (coefficients (make-array n-points :element-type 'double-float)) 50 | (values z) 51 | previous-values 52 | ((&flet weighted-sum (values) 53 | (/ (loop for v across values 54 | for f across f-at-z 55 | summing (* f v)) 56 | (/ n-points 2))))) 57 | (declare (type simple-double-float-vector 58 | z f-at-z values previous-values)) 59 | (loop for j from 0 below n-polynomials 60 | do (setf (aref coefficients j) 61 | (if (zerop j) 62 | (/ (reduce #'+ f-at-z) n-points) 63 | (progn 64 | (cond 65 | ((= j 1) (weighted-sum z)) 66 | ((= j 2) (setf values 67 | (map 'simple-double-float-vector 68 | (lambda (z) 69 | (chebyshev-recursion z z 1d0)) 70 | z))) 71 | ((= j 3) 72 | (setf previous-values values 73 | values (map 'simple-double-float-vector 74 | #'chebyshev-recursion 75 | z previous-values z))) 76 | (t (map-into previous-values 77 | #'chebyshev-recursion z values previous-values) 78 | (rotatef values previous-values))) 79 | (weighted-sum values))))) 80 | coefficients))) 81 | 82 | (defun chebyshev-evaluate (coefficients x) 83 | "Return the sum of Chebyshev polynomials, weighted by COEFFICIENTS, at X." 84 | (let ((value (coerce x 'double-float)) 85 | (previous-value 1d0) 86 | (sum 0d0)) 87 | (dotimes (index (length coefficients)) 88 | (incf sum (* (aref coefficients index) 89 | (cond 90 | ((= index 0) 1d0) 91 | ((= index 1) x) 92 | (t (setf previous-value (chebyshev-recursion x value previous-value)) 93 | (rotatef value previous-value) 94 | value))))) 95 | sum)) 96 | 97 | 98 | 99 | (declaim (inline ab-to-cinf cinf-to-ab ab-to-cd-intercept-slope)) 100 | 101 | (defun cinf-to-ab (x a b c) 102 | "Map x in [c,plus-infinity) to z in [a,b] using x -> (x-c)/(1+x-c)+(b-a)+a." 103 | (let ((xc (- x c))) 104 | (assert (<= 0 xc) () "Value outside domain.") 105 | (+ (* (/ xc (1+ xc)) (- b a)) a))) 106 | 107 | (defun ab-to-cinf (z a b c) 108 | "Inverse of cinf-to-ab." 109 | (let ((z-norm (/ (- z a) (- b a)))) 110 | (assert (within? 0 z-norm 1) () "Value outside domain.") 111 | (+ c (/ z-norm (- 1 z-norm))))) 112 | 113 | (defun ab-to-cd-intercept-slope (a b c d) 114 | "Return (values INTERCEPT SLOPE) for linear mapping x:-> intercept+slope*x 115 | from [a,b] to [c,d]." 116 | (let ((b-a (- b a))) 117 | (values (/ (- (* b c) (* a d)) b-a) 118 | (/ (- d c) b-a)))) 119 | 120 | (defun chebyshev-approximate (f interval n-polynomials 121 | &key (n-points n-polynomials)) 122 | "Return a closure approximating F on the given INTERVAL (may be infinite on 123 | either end) using the given number of Chebyshev polynomials." 124 | (chebyshev-approximate-implementation f interval n-polynomials n-points)) 125 | 126 | (defgeneric chebyshev-approximate-implementation (f interval n-polynomials 127 | n-points) 128 | (:documentation "Implementation of CHEBYSHEV-APPROXIMATE.") 129 | (:method (f (interval plusinf-interval) n-polynomials n-points) 130 | (let+ (((&interval (left open-left?) &ign) interval) 131 | (a (if open-left? 132 | -1d0 133 | (chebyshev-root n-points 0))) 134 | (left (coerce left 'double-float)) 135 | (coefficients 136 | (chebyshev-regression (lambda (z) 137 | (funcall f (ab-to-cinf z a 1d0 left))) 138 | n-polynomials n-points))) 139 | (lambda (x) 140 | (chebyshev-evaluate coefficients (cinf-to-ab x a 1d0 left))))) 141 | (:method (f (interval finite-interval) n-polynomials n-points) 142 | (let+ (((&interval (left open-left?) (right open-right?)) interval)) 143 | (assert (< left right)) 144 | (let+ ((a (if open-left? 145 | -1d0 146 | (chebyshev-root n-points 0))) 147 | (b (if open-right? 148 | 1d0 149 | (chebyshev-root n-points (1- n-points)))) 150 | ((&values intercept slope) (ab-to-cd-intercept-slope left right a b)) 151 | (coefficients (chebyshev-regression (lambda (z) 152 | (funcall f (/ (- z intercept) 153 | slope))) 154 | n-polynomials n-points))) 155 | (lambda (x) 156 | (chebyshev-evaluate coefficients (+ intercept (* slope x)))))))) 157 | -------------------------------------------------------------------------------- /src/utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*- 2 | 3 | (cl:defpackage #:cl-num-utils.utilities 4 | (:use #:cl 5 | #:alexandria 6 | #:anaphora 7 | #:let-plus) 8 | (:export 9 | #:gethash* 10 | #:splice-when 11 | #:splice-awhen 12 | #:curry* 13 | #:check-types 14 | #:define-with-multiple-bindings 15 | #:unlessf 16 | #:within? 17 | #:fixnum? 18 | #:simple-fixnum-vector 19 | #:as-simple-fixnum-vector 20 | #:as-double-float 21 | #:with-double-floats 22 | #:simple-double-float-vector 23 | #:generate-sequence 24 | #:expanding 25 | #:bic 26 | #:binary-search 27 | #:as-alist 28 | #:as-plist)) 29 | 30 | (cl:in-package #:cl-num-utils.utilities) 31 | 32 | (defmacro gethash* (key hash-table 33 | &optional (datum "Key not found.") 34 | &rest arguments) 35 | "Like GETHASH, but checking that KEY is present and raising the given error if not." 36 | (with-unique-names (value present?) 37 | `(multiple-value-bind (,value ,present?) (gethash ,key ,hash-table) 38 | (assert ,present? () ,datum ,@arguments) 39 | ,value))) 40 | 41 | (defmacro splice-when (test &body forms) 42 | "Similar to when, but wraps the result in list. 43 | 44 | Example: `(,foo ,@(splice-when add-bar? bar))" 45 | `(when ,test 46 | (list 47 | (progn ,@forms)))) 48 | 49 | (defmacro splice-awhen (test &body forms) 50 | "Similar to splice-when, but binds IT to test." 51 | `(awhen ,test 52 | (list 53 | (progn ,@forms)))) 54 | 55 | (defmacro curry* (function &rest arguments) 56 | "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." 57 | (let ((arguments (loop for arg in arguments 58 | collect (cond 59 | ((eq arg '*) (gensym "ARG")) 60 | ((keywordp arg) (list arg)) 61 | (t (list (gensym "VAR") arg)))))) 62 | `(let ,(loop for arg in arguments 63 | when (and (consp arg) (cdr arg)) 64 | collect arg) 65 | (lambda ,(loop for arg in arguments 66 | unless (consp arg) 67 | collect arg) 68 | (,function ,@(loop for arg in arguments 69 | collect (if (consp arg) 70 | (car arg) 71 | arg))))))) 72 | 73 | (defmacro check-types ((&rest arguments) type) 74 | "CHECK-TYPE for multiple places of the same type. Each argument is either a place, or a list of a place and a type-string." 75 | `(progn 76 | ,@(loop 77 | for argument :in arguments 78 | collecting (if (atom argument) 79 | `(check-type ,argument ,type) 80 | (let+ (((place type-string) argument)) 81 | `(check-type ,place ,type ,type-string)))))) 82 | 83 | (defmacro define-with-multiple-bindings 84 | (macro &key 85 | (plural (intern (format nil "~aS" macro))) 86 | (docstring (format nil "Multiple binding version of ~(~a~)." macro))) 87 | "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)." 88 | `(defmacro ,plural (bindings &body body) 89 | ,docstring 90 | (if bindings 91 | `(,',macro ,(car bindings) 92 | (,',plural ,(cdr bindings) 93 | ,@body)) 94 | `(progn ,@body)))) 95 | 96 | (defmacro unlessf (place value-form &environment environment) 97 | "When PLACE is NIL, evaluate VALUE-FORM and save it there." 98 | (multiple-value-bind (vars vals store-vars writer-form reader-form) 99 | (get-setf-expansion place environment) 100 | `(let* ,(mapcar #'list vars vals) 101 | (unless ,reader-form 102 | (let ((,(car store-vars) ,value-form)) 103 | ,writer-form))))) 104 | 105 | (declaim (inline within?)) 106 | (defun within? (left value right) 107 | "Return non-nil iff value is in [left,right)." 108 | (and (<= left value) (< value right))) 109 | 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 or 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 the 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 | (defun as-double-float (v) 126 | "Convert argument to DOUBLE-FLOAT." 127 | (coerce v 'double-float)) 128 | 129 | (defmacro with-double-floats (bindings &body body) 130 | "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. 131 | 132 | Example: 133 | (with-double-floats (a 134 | (b) 135 | (c 1)) 136 | ...)" 137 | `(let ,(mapcar (lambda (binding) 138 | (let+ (((variable &optional (value variable)) 139 | (ensure-list binding))) 140 | `(,variable (as-double-float ,value)))) 141 | bindings) 142 | ,@body)) 143 | 144 | (deftype simple-double-float-vector (&optional (length '*)) 145 | "Simple vector of double-float elements." 146 | `(simple-array double-float (,length))) 147 | 148 | (defun generate-sequence (result-type size function) 149 | "Like MAKE-SEQUENCE, but using a function to fill the result." 150 | (map-into (make-sequence result-type size) function)) 151 | 152 | (defmacro expanding (&body body) 153 | "Expand BODY. Useful for generating code programmatically." 154 | (with-gensyms (local-macro) 155 | `(macrolet ((,local-macro () 156 | ,@body)) 157 | (,local-macro)))) 158 | 159 | (defun bic (a b) 160 | "Biconditional. Returns A <=> B." 161 | (if a b (not b))) 162 | 163 | (defun binary-search (sorted-reals value) 164 | "Return INDEX such that 165 | 166 | (WITHIN? (AREF SORTED-REALS INDEX) VALUE (AREF SORTED-REALS (1+ INDEX)). 167 | 168 | 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). 169 | 170 | If value is below (or above) the first (last) break, NIL (T) is returned." 171 | (let+ ((left 0) 172 | (right (1- (length sorted-reals))) 173 | ((&flet sr (index) (aref sorted-reals index)))) 174 | (cond 175 | ((< value (sr left)) nil) 176 | ((<= (sr right) value) t) 177 | (t (loop 178 | (when (= (1+ left) right) 179 | (return left)) 180 | (let ((middle (floor (+ left right) 2))) 181 | (if (< value (sr middle)) 182 | (setf right middle) 183 | (setf left middle)))))))) 184 | 185 | (defgeneric as-alist (object) 186 | (:documentation "Return OBJECT as an ALIST. Semantics depends on OBJECT.")) 187 | 188 | (defgeneric as-plist (object) 189 | (:documentation "Return OBJECT as a PLIST. Semantics depends on OBJECT. The default method uses AS-ALIST.") 190 | (:method (object) 191 | (alist-plist (as-alist object)))) 192 | -------------------------------------------------------------------------------- /src/quadrature.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (cl:defpackage #:cl-num-utils.quadrature 4 | (:use #:cl 5 | #:alexandria 6 | #:anaphora 7 | #:cl-num-utils.arithmetic 8 | #:cl-num-utils.interval 9 | #:cl-num-utils.utilities 10 | #:let-plus) 11 | (:export 12 | #:romberg-quadrature)) 13 | 14 | (cl:in-package #:cl-num-utils.quadrature) 15 | 16 | ;;;; Richardson extrapolation (general framework) 17 | 18 | (defstruct (richardson-extrapolation 19 | (:constructor richardson-extrapolation 20 | (coefficient iterations 21 | &aux (diagonal (make-array iterations 22 | :element-type 'double-float))))) 23 | "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. 24 | 25 | The algorithm uses Richardson extrapolation, the required coefficient is q^k." 26 | (coefficient nil :type double-float) 27 | (n 0 :type fixnum) 28 | (diagonal nil :type (array double-float (*)))) 29 | 30 | (defun richardson-iteration (extrapolation step) 31 | "Add STEP (= $A(h q^{-k}$) to an existing Richardson EXTRAPOLATION. See the documentation of RICHARDSON-EXTRAPOLATION for details." 32 | (let+ (((&structure-r/o richardson-extrapolation- coefficient n diagonal) 33 | extrapolation) 34 | (largest-relative-change 0d0) 35 | (step (coerce step 'double-float))) 36 | (when (= n (length diagonal)) 37 | (error 'reached-maximum-iterations :n n)) 38 | (loop with product := coefficient 39 | for m from 0 below n 40 | do (let ((correction (/ (- step (aref diagonal m)) 41 | (1- product)))) 42 | (setf (aref diagonal m) step) 43 | (maxf largest-relative-change (/ (abs correction) (abs step))) 44 | (incf step correction) 45 | (multf product coefficient))) 46 | (setf (aref diagonal n) step) 47 | (incf (richardson-extrapolation-n extrapolation)) 48 | (values step largest-relative-change))) 49 | 50 | ;;;; iterative quadrature: generic interface 51 | 52 | (defstruct iterative-quadrature 53 | "Quadrature building block. 54 | 55 | F is the function. 56 | 57 | A and B are the endpoints. 58 | 59 | H is the stepsize." 60 | (f nil :type (function (double-float) double-float)) 61 | (a nil :type double-float) 62 | (b nil :type double-float) 63 | (h nil :type double-float) 64 | (n 0 :type fixnum) 65 | (sum 0d0 :type double-float)) 66 | 67 | (defgeneric refine-quadrature (quadrature) 68 | (:documentation "Refine quadrature with more points. Return the sum for those points.")) 69 | 70 | (defgeneric richardson-coefficient (quadrature) 71 | (:documentation "Return the coefficient $q$ for Richardson approximation.")) 72 | 73 | ;;; trapezoidal quadrature 74 | 75 | (defstruct (trapezoidal-quadrature 76 | (:include iterative-quadrature) 77 | (:constructor trapezoidal-quadrature%))) 78 | 79 | (defun trapezoidal-quadrature (f a b) 80 | (with-double-floats (a b) 81 | (trapezoidal-quadrature% :f f :a a :b b :h (- b a)))) 82 | 83 | (defmethod refine-quadrature ((quadrature trapezoidal-quadrature)) 84 | (let+ (((&structure-r/o iterative-quadrature- a b f) quadrature) 85 | ((&structure iterative-quadrature- n h sum) quadrature)) 86 | (setf sum 87 | (if (zerop n) 88 | (* (+ (funcall f a) (funcall f b)) h 0.5d0) 89 | (+ (/ sum 2) 90 | (let* ((h h)) 91 | (* h 92 | (loop 93 | repeat (expt 2 (1- n)) 94 | for x from (+ a h) by (* 2 h) 95 | summing (funcall f x))))))) 96 | (incf n) 97 | (multf h 1/2) 98 | sum)) 99 | 100 | (defmethod richardson-coefficient ((quadrature trapezoidal-quadrature)) 101 | 4d0) 102 | 103 | ;;; midpoint quadrature 104 | 105 | (defstruct (midpoint-quadrature 106 | (:include iterative-quadrature) 107 | (:constructor midpoint-quadrature%))) 108 | 109 | (defun midpoint-quadrature (f a b) 110 | (with-double-floats (a b) 111 | (midpoint-quadrature% :f f :a a :b b :h (- b a)))) 112 | 113 | (defmethod refine-quadrature ((quadrature midpoint-quadrature)) 114 | ;; (declare (optimize speed)) 115 | (let+ (((&structure-r/o iterative-quadrature- a b f) quadrature) 116 | ((&structure iterative-quadrature- n h sum) quadrature)) 117 | (setf sum 118 | (if (zerop n) 119 | (* h (+ (funcall f (/ (+ a b) 2)))) 120 | (+ (/ sum 3) 121 | (let* ((h h) 122 | (2h (* 2 h)) 123 | (s 0d0)) 124 | (loop 125 | repeat (expt 3 (1- n)) 126 | with x = (+ a (/ h 2)) 127 | do (incf s (funcall f x)) 128 | (incf x 2h) 129 | (incf s (funcall f x)) 130 | (incf x h)) 131 | (* h s))))) 132 | (incf n) 133 | (multf h 1/3) 134 | sum)) 135 | 136 | (defmethod richardson-coefficient ((quadrature midpoint-quadrature)) 137 | 9d0) 138 | 139 | ;;; implementation of Romberg quadrature 140 | 141 | (defun romberg-quadrature% (quadrature epsilon min-iter max-iter) 142 | "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." 143 | (loop with re = (richardson-extrapolation 144 | (richardson-coefficient quadrature) max-iter) 145 | do (let+ ((q (refine-quadrature quadrature)) 146 | ((&values q-extrapolated change) (richardson-iteration re q)) 147 | (n (richardson-extrapolation-n re))) 148 | (when (and (<= min-iter n) 149 | (<= change epsilon)) 150 | (return-from romberg-quadrature% (values q-extrapolated n)))))) 151 | 152 | (defgeneric transformed-quadrature (function interval transformation) 153 | (: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.") 154 | (:method (function (interval finite-interval) (transformation null)) 155 | (let+ (((&interval (a a-open?) (b b-open?)) interval)) 156 | (if (or a-open? b-open?) 157 | (midpoint-quadrature function a b) 158 | (trapezoidal-quadrature function a b)))) 159 | (:method (function (interval plusinf-interval) (transformation null)) 160 | (let+ (((&accessors-r/o left) interval)) 161 | (midpoint-quadrature (lambda (y) 162 | (let ((1-y (- 1 y))) 163 | (/ (funcall function (+ left (/ y 1-y))) 164 | (expt 1-y 2)))) 165 | 0 1)))) 166 | 167 | (defun romberg-quadrature (f interval &key (epsilon (sqrt double-float-epsilon)) 168 | (min-iter 5) 169 | (max-iter 20) 170 | transformation) 171 | "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." 172 | (romberg-quadrature% (transformed-quadrature f interval transformation) 173 | epsilon min-iter max-iter)) 174 | -------------------------------------------------------------------------------- /src/elementwise.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (cl:defpackage #:cl-num-utils.elementwise 4 | (:use #:cl 5 | #:alexandria 6 | #:cl-num-utils.arithmetic 7 | #:cl-num-utils.utilities 8 | #:let-plus) 9 | (:export 10 | #:elementwise-float-contagion 11 | #:e+ 12 | #:e- 13 | #:e* 14 | #:e/ 15 | #:e2+ 16 | #:e2- 17 | #:e2* 18 | #:e2/ 19 | #:e1- 20 | #:e1/ 21 | #:e2log 22 | #:e2exp 23 | #:e1log 24 | #:e1exp 25 | #:eexpt 26 | #:eexp 27 | #:elog 28 | #:esqrt 29 | #:econjugate 30 | #:ereduce 31 | #:emin 32 | #:emax)) 33 | 34 | (cl:in-package #:cl-num-utils.elementwise) 35 | 36 | (defun elementwise-float-contagion (&rest objects) 37 | "Return the resulting float type when objects (or their elements) are combined using arithmetic operations." 38 | ;; TODO benchmark, optimize 39 | (let* ((matrix (load-time-value 40 | (let ((matrix (make-array `(10 10) 41 | :element-type '(integer 0 9)))) 42 | (dotimes (i1 10) 43 | (dotimes (i2 10) 44 | (let+ (((&values c1 f1) (floor i1 5)) 45 | ((&values c2 f2) (floor i2 5))) 46 | (setf (aref matrix i1 i2) 47 | (+ (max f1 f2) (* 5 (max c1 c2))))))) 48 | matrix)))) 49 | (declare (type (simple-array (integer 0 9) (10 10)) matrix)) 50 | (if objects 51 | (aref #(real 52 | short-float 53 | single-float 54 | double-float 55 | long-float 56 | complex 57 | (complex short-float) 58 | (complex single-float) 59 | (complex double-float) 60 | (complex long-float)) 61 | (reduce (lambda (i1 i2) (aref matrix i1 i2)) objects 62 | :key (lambda (object) 63 | (cond 64 | ((arrayp object) 65 | (let ((type (array-element-type object))) 66 | (cond 67 | ((subtypep type 'short-float) 1) 68 | ((subtypep type 'single-float) 2) 69 | ((subtypep type 'double-float) 3) 70 | ((subtypep type 'long-float) 4) 71 | ((subtypep type 'real) 0) 72 | ((subtypep type '(complex short-float)) 6) 73 | ((subtypep type '(complex single-float)) 7) 74 | ((subtypep type '(complex double-float)) 8) 75 | ((subtypep type '(complex long-float)) 9) 76 | ((subtypep type 'complex) 5) 77 | (t (return-from elementwise-float-contagion t))))) 78 | ((typep object 'short-float) 1) 79 | ((typep object 'single-float) 2) 80 | ((typep object 'double-float) 3) 81 | ((typep object 'long-float) 4) 82 | ((typep object 'real) 0) 83 | ((typep object '(complex short-float)) 6) 84 | ((typep object '(complex single-float)) 7) 85 | ((typep object '(complex double-float)) 8) 86 | ((typep object '(complex long-float)) 9) 87 | ((typep object 'complex) 5) 88 | (t (return-from elementwise-float-contagion t)))))) 89 | t))) 90 | 91 | ;;; various elementwise operations 92 | 93 | (defmacro mapping-array ((ref array &rest other) form) 94 | (check-type ref symbol) 95 | (with-unique-names (result index) 96 | (once-only (array) 97 | `(let ((,result (make-array (array-dimensions ,array) 98 | :element-type (elementwise-float-contagion 99 | ,array ,@other)))) 100 | (dotimes (,index (array-total-size ,result)) 101 | (setf (row-major-aref ,result ,index) 102 | (flet ((,ref (array) 103 | (row-major-aref array ,index))) 104 | ,form))) 105 | ,result)))) 106 | 107 | (defmacro define-e1 (operation 108 | &key (function (symbolicate '#:e1 operation)) 109 | (docstring (format nil "Univariate elementwise ~A." 110 | operation))) 111 | "Define an univariate elementwise operation." 112 | (check-types (function operation) symbol) 113 | `(defgeneric ,function (a) 114 | (declare (optimize speed)) 115 | (:documentation ,docstring) 116 | (:method ((a number)) 117 | (,operation a)) 118 | (:method ((a array)) 119 | (mapping-array (m a) (,operation (m a)))))) 120 | 121 | (define-e1 -) 122 | (define-e1 /) 123 | (define-e1 log) 124 | (define-e1 exp :function eexp) 125 | (define-e1 sqrt :function esqrt) 126 | (define-e1 conjugate :function econjugate) 127 | (define-e1 square :function esquare) 128 | 129 | (defmacro define-e2 (operation 130 | &key (function (symbolicate '#:e2 operation)) 131 | (docstring (format nil "Bivariate elementwise ~A." 132 | operation))) 133 | "Define an univariate elementwise operation." 134 | (check-types (function operation) symbol) 135 | `(defgeneric ,function (a b) 136 | (declare (optimize speed)) 137 | (:documentation ,docstring) 138 | (:method ((a number) (b number)) 139 | (,operation a b)) 140 | (:method ((a array) (b number)) 141 | (mapping-array (m a b) (,operation (m a) b))) 142 | (:method ((a number) (b array)) 143 | (mapping-array (m b a) (,operation a (m b)))) 144 | (:method ((a array) (b array)) 145 | (assert (equal (array-dimensions a) (array-dimensions b))) 146 | (mapping-array (m a b) (,operation (m a) (m b)))))) 147 | 148 | 149 | (define-e2 +) 150 | (define-e2 -) 151 | (define-e2 *) 152 | (define-e2 /) 153 | (define-e2 expt :function eexpt) 154 | (define-e2 log) 155 | 156 | (defun elog (a &optional (base nil base?)) 157 | "Elementwise logarithm." 158 | (if base? 159 | (e2log a base) 160 | (e1log a))) 161 | 162 | (defmacro define-e& (operation &key (function (symbolicate '#:e operation)) 163 | (bivariate (symbolicate '#:e2 operation)) 164 | (univariate (symbolicate '#:e1 operation)) 165 | (docstring (format nil "Elementwise ~A." 166 | operation))) 167 | `(defun ,function (argument &rest more-arguments) 168 | ,docstring 169 | (if more-arguments 170 | (reduce #',bivariate more-arguments :initial-value argument) 171 | (,univariate argument)))) 172 | 173 | (define-e& + :univariate identity) 174 | (define-e& -) 175 | (define-e& * :univariate identity) 176 | (define-e& /) 177 | 178 | (defgeneric ereduce (function object &key key) 179 | (:documentation "Elementwise reduce, traversing in row-major order.") 180 | (:method (function (array array) &key key) 181 | (reduce function (aops:flatten array) :key key)) 182 | (:method (function (sequence sequence) &key key) 183 | (reduce function sequence :key key)) 184 | (:method (function object &key key) 185 | (reduce function (aops:as-array object) :key key))) 186 | 187 | (defmacro define-elementwise-reduction 188 | (name function 189 | &optional (docstring (format nil "Elementwise ~A." function))) 190 | `(defun ,name (object) 191 | ,docstring 192 | (ereduce #',function object))) 193 | 194 | (define-elementwise-reduction emax max) 195 | (define-elementwise-reduction emin min) 196 | -------------------------------------------------------------------------------- /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/rootfinding.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*- 2 | 3 | (cl:defpackage #:cl-num-utils.rootfinding 4 | (:use #:cl 5 | #:alexandria 6 | #:cl-num-utils.interval 7 | #:cl-num-utils.utilities 8 | #:let-plus) 9 | (:export 10 | #:*rootfinding-epsilon* 11 | #:*rootfinding-delta-relative* 12 | #:root-bisection)) 13 | 14 | (cl:in-package #:cl-num-utils.rootfinding) 15 | 16 | ;;; Testing convergence of rootfinding methods 17 | 18 | (defun opposite-sign? (a b) 19 | "Return true iff A and B are on opposite sides of 0." 20 | (or (and (minusp a) (plusp b)) 21 | (and (plusp a) (minusp b)))) 22 | 23 | (defun narrow-bracket? (a b delta) 24 | "Return true iff $|a-b| < \\delta$." 25 | (< (abs (- a b)) delta)) 26 | 27 | (defun near-root? (f epsilon) 28 | "Return true iff $|f| < \\epsilon$." 29 | (< (abs f) epsilon)) 30 | 31 | (defparameter *rootfinding-epsilon* (expt double-float-epsilon 0.25) 32 | "Default maximum for the absolute value of the function, used for rootfinding.") 33 | 34 | (defparameter *rootfinding-delta-relative* (expt double-float-epsilon 0.25) 35 | "Default relative interval width for rootfinding.") 36 | 37 | (defun rootfinding-delta (interval 38 | &optional (delta-relative *rootfinding-delta-relative*)) 39 | "Default DELTA for rootfinding methods, uses bracket width." 40 | (* (interval-length interval) delta-relative)) 41 | 42 | ;;; convenience macro for various univariate rootfinders 43 | 44 | (defmacro univariate-rootfinder-loop% (((f a b fa fb) 45 | (f-tested test-bracket delta epsilon)) 46 | &body body) 47 | "Common parts for univariate rootfinder functions. 48 | 49 | Sets up the following: 50 | 51 | - function OPPOSITE-SIGN-P for checking that two numbers are on the opposite side of 0 52 | 53 | - 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 54 | 55 | - 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)) 56 | 57 | - variables FA and FB to hold function values at A and B 58 | 59 | 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." 60 | (check-types (a b fa fb) symbol) 61 | (with-unique-names (block-name) 62 | (once-only (delta epsilon f) 63 | `(block ,block-name 64 | (flet ((,f-tested (x) 65 | (let ((fx (funcall ,f x))) 66 | (if (near-root? fx ,epsilon) 67 | (return-from ,block-name (values x fx t (interval ,a ,b))) 68 | fx))) 69 | (,test-bracket (fx x) 70 | (when (narrow-bracket? ,a ,b ,delta) 71 | (return-from ,block-name 72 | (values x fx nil ,a ,b))))) 73 | (assert (and (<= 0 ,delta) (<= 0 ,epsilon))) 74 | (when (< ,b ,a) 75 | (rotatef ,a ,b)) 76 | (let* ((,a (coerce ,a 'double-float)) 77 | (,b (coerce ,b 'double-float)) 78 | (,fa (,f-tested ,a)) 79 | (,fb (,f-tested ,b))) 80 | (unless (opposite-sign? ,fa ,fb) 81 | (error "Boundaries don't bracket 0.")) 82 | (loop 83 | ,@body))))))) 84 | 85 | (defun root-bisection (f bracket 86 | &key (delta (rootfinding-delta bracket)) 87 | (epsilon *rootfinding-epsilon*)) 88 | "Find the root of f bracketed between a and b using bisection. 89 | The algorithm stops when either the root is bracketed in an interval of length 90 | TOLERANCE (relative to the initial |a-b|), or root is found such that 91 | abs(f(root)) <= epsilon. 92 | 93 | Return five values: the root, the value of the function at the root, and a 94 | boolean which is true iff abs(f(root)) <= epsilon. If the third value is 95 | true, the fourth and fifth values are the endpoints of the bracketing 96 | interval, otherwise they are undefined." 97 | (let+ (((&interval a b) bracket)) 98 | (univariate-rootfinder-loop% ((f a b fa fb) 99 | (f-tested test-bracket delta epsilon)) 100 | (let* ((m (/ (+ a b) 2)) 101 | (fm (f-tested m))) 102 | (test-bracket fm m) 103 | (if (opposite-sign? fa fm) 104 | (setf b m 105 | fb fm) 106 | (setf a m 107 | fa fm)))))) 108 | 109 | ;; (defun root-ridders (f a b &key 110 | ;; (tolerance (* (abs (- b a)) #.(expt double-float-epsilon 0.25))) 111 | ;; (epsilon #.(expt double-float-epsilon 0.25))) 112 | ;; "Find the root of f bracketed between a and b using Ridders' method. 113 | ;; The algorithm stops when either the root is bracketed in an interval 114 | ;; of length tolerance, or root is found such that abs(f(root)) <= 115 | ;; epsilon. 116 | 117 | ;; Return five values: the root, the function evaluated at the root, and 118 | ;; a boolean which is true iff abs(f(root)) <= epsilon. If the third 119 | ;; value is true, the fourth and fifth values are the endpoints of the 120 | ;; bracketing interval, otherwise they are undefined." 121 | ;; ;; (declare (double-float a b tolerance epsilon) 122 | ;; ;; ((function (double-float) double-float) f)) 123 | ;; (univariate-rootfinder-common-setup root-ridders 124 | ;; (macrolet ((new-bracket (a b fa fb) 125 | ;; `(progn 126 | ;; (setf a ,a 127 | ;; b ,b 128 | ;; fa ,fa 129 | ;; fb ,fb) 130 | ;; (go top)))) 131 | ;; (tagbody 132 | ;; top 133 | ;; ;;; (format t "~a ~a~%" a b) 134 | ;; (let* ((m (half (+ a b))) ; midpoint 135 | ;; (fm (evaluate-and-return-if-within-epsilon m))) ; value at midpoint 136 | ;; (return-if-within-tolerance m fm a b) 137 | ;; (let* ((w (- (square fm) (* fa fb))) ; discriminant 138 | ;; (delta (/ (* (signum fa) fm (- b m)) (sqrt w))) ; c-m 139 | ;; (c (+ m delta)) ; interpolated guess 140 | ;; (fc (evaluate-and-return-if-within-epsilon c))) ; value at guess 141 | ;; (if (minusp delta) 142 | ;; ;; c < m 143 | ;; (cond 144 | ;; ((opposite-sign-p fm fc) (new-bracket c m fc fm)) 145 | ;; ((opposite-sign-p fa fc) (new-bracket a c fa fc)) 146 | ;; ((opposite-sign-p fb fc) (new-bracket c b fc fb)) 147 | ;; (t (error "internal error"))) 148 | ;; ;; m < c 149 | ;; (cond 150 | ;; ((opposite-sign-p fm fc) (new-bracket m c fm fc)) 151 | ;; ((opposite-sign-p fb fc) (new-bracket c b fc fb)) 152 | ;; ((opposite-sign-p fa fc) (new-bracket a c fa fc)) 153 | ;; (t (error "internal error")))))))))) 154 | 155 | 156 | 157 | ;; (defun find-satisfactory-fx (x f next-x-rule &key 158 | ;; (satisfactory-p #'minusp) 159 | ;; (maximum-iterations 100)) 160 | ;; "Try a sequence of x's (starting from x, generating the next one by 161 | ;; next-x-rule) until f(x) satisfies the predicate. Return (values x 162 | ;; fx). If maximum-iterations are reached, an error is signalled." 163 | ;; (dotimes (i maximum-iterations) 164 | ;; (let ((fx (funcall f x))) 165 | ;; (if (funcall satisfactory-p fx) 166 | ;; (return-from find-satisfactory-fx (values x fx)) 167 | ;; (setf x (funcall next-x-rule x))))) 168 | ;; ;; !!!! todo: decent error reporting with a condition 169 | ;; (error "reached maximum number of iterations")) 170 | 171 | 172 | ;; (defun make-expanding-rule (deltax multiplier) 173 | ;; "Creates a function that adds an ever-increasing (starting with 174 | ;; deltax, multiplied by multiplier at each step) to its argument. 175 | ;; Primarily for use with root-autobracket." 176 | ;; (assert (< 1 multiplier)) 177 | ;; (lambda (x) 178 | ;; (let ((new-x (+ x deltax))) 179 | ;; (multf deltax multiplier) 180 | ;; new-x))) 181 | 182 | ;; (defun make-contracting-rule (attractor coefficient) 183 | ;; "Creates a function that brings its argument closer to attractor, 184 | ;; contracting the distance by coefficient at each step. Primarily for 185 | ;; use with autobracket." 186 | ;; (assert (< 0 coefficient 1)) 187 | ;; (lambda (x) 188 | ;; (+ (* (- x attractor) coefficient) attractor))) 189 | 190 | ;; (defun root-autobracket (f x negative-rule positive-rule 191 | ;; &key (maximum-iterations 100) 192 | ;; (rootfinder #'root-ridders) 193 | ;; (tolerance #.(expt double-float-epsilon 0.25)) 194 | ;; (epsilon #.(expt double-float-epsilon 0.25))) 195 | ;; "Rootfinder with automatic bracketing. First we evaluate at x, and 196 | ;; check if it is a root. If not, and f(x) is positive, we try to locate 197 | ;; a satisfactory bracket by generating x's using positive-rule. Mutatis 198 | ;; mutandis if f(x) is negative. 199 | 200 | ;; Since the bracket is not known beforehand, you can only specify a 201 | ;; relative tolerance. For the meaning of other parameters, see 202 | ;; rootfinding functions and find-satisfactory-fx." 203 | ;; (assert (<= 0 epsilon)) 204 | ;; (let ((fx (funcall f x))) 205 | ;; (cond 206 | ;; ;; found root 207 | ;; ((<= (abs fx) epsilon) 208 | ;; (values x fx)) 209 | ;; ;; no root, trying to find a negative value for bracketing 210 | ;; ((plusp fx) 211 | ;; (bind (((values y fy) (find-satisfactory-fx x f positive-rule 212 | ;; :satisfactory-p #'minusp 213 | ;; :maximum-iterations maximum-iterations))) 214 | ;; (if (<= (abs fy) epsilon) 215 | ;; (values y fy) 216 | ;; (funcall rootfinder f x y 217 | ;; :tolerance ;(* (absolute-difference x y) 218 | ;; tolerance ;) 219 | ;; :epsilon epsilon)))) 220 | ;; ((minusp fx) 221 | ;; (bind (((values y fy) (find-satisfactory-fx x f negative-rule 222 | ;; :satisfactory-p #'plusp 223 | ;; :maximum-iterations maximum-iterations))) 224 | ;; (if (<= (abs fy) epsilon) 225 | ;; (values y fy) 226 | ;; (funcall rootfinder f x y 227 | ;; :tolerance ;(* (absolute-difference x y) 228 | ;; tolerance ;) 229 | ;; :epsilon epsilon))))))) 230 | 231 | ;;; (root-autobracket #'identity 5 (make-expanding-rule 1 2) 232 | ;;; (make-expanding-rule -1 2)) 233 | -------------------------------------------------------------------------------- /src/arithmetic.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (defpackage #:cl-num-utils.arithmetic 4 | (:use #:cl 5 | #:alexandria 6 | #:anaphora 7 | #:cl-num-utils.utilities 8 | #:let-plus) 9 | (:export 10 | #:multf 11 | #:same-sign? 12 | #:square 13 | #:absolute-square 14 | #:abs-diff 15 | #:log10 16 | #:log2 17 | #:1c 18 | #:divides? 19 | #:as-integer 20 | #:numseq 21 | #:ivec 22 | #:sum 23 | #:product 24 | #:cumulative-sum 25 | #:cumulative-product 26 | #:l2norm-square 27 | #:l2norm 28 | #:normalize-probabilities 29 | #:floor* 30 | #:ceiling* 31 | #:round* 32 | #:truncate*)) 33 | 34 | (in-package #:cl-num-utils.arithmetic) 35 | 36 | ;;; simple arithmetic 37 | 38 | (define-modify-macro multf (coefficient) * "Multiply place by COEFFICIENT.") 39 | 40 | (defun same-sign? (&rest arguments) 41 | "Test whether all arguments have the same sign (ie all are positive, negative, or zero)." 42 | (if arguments 43 | (let+ (((first . rest) arguments) 44 | (sign (signum first))) 45 | (every (lambda (number) (= sign (signum number))) rest)) 46 | t)) 47 | 48 | (declaim (inline square)) 49 | (defun square (number) 50 | "Square of number." 51 | (expt number 2)) 52 | 53 | (declaim (inline absolute-square)) 54 | (defun absolute-square (number) 55 | "Number multiplied by its complex conjugate." 56 | (* (conjugate number) number)) 57 | 58 | (declaim (inline abs-diff)) 59 | (defun abs-diff (a b) 60 | "Absolute difference of A and B." 61 | (abs (- a b))) 62 | 63 | ;;;; Aliases for commonly used log bases. 64 | (declaim (inline log10 log2)) 65 | 66 | (defun log10 (number) 67 | "Abbreviation for decimal logarithm." 68 | (log number 10)) 69 | 70 | (defun log2 (number) 71 | "Abbreviation for binary logarithm." 72 | (log number 2)) 73 | 74 | (declaim (inline 1c)) 75 | 76 | (defun 1c (number) 77 | "Return 1-number. The mnemonic is \"1 complement\", 1- is already a CL 78 | library function." 79 | (- 1 number)) 80 | 81 | (defun divides? (number divisor) 82 | "Test if DIVISOR divides NUMBER without remainder, and if so, return the 83 | quotient. Works generally, but makes most sense for rationals." 84 | (let+ (((&values quot rem) (floor number divisor))) 85 | (when (zerop rem) 86 | quot))) 87 | 88 | (defun as-integer (number) 89 | "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." 90 | (declare (inline as-integer)) 91 | (etypecase number 92 | (integer number) 93 | (complex 94 | (assert (zerop (imagpart number)) () 95 | "~A has non-zero imaginary part." number) 96 | (as-integer (realpart number))) 97 | (t (aprog1 (rationalize number) 98 | (assert (integerp it) () "~A has non-zero fractional part." number))))) 99 | 100 | 101 | ;;; arithmetic sequences 102 | 103 | (defun numseq (from to &key length (by (unless length 1)) type) 104 | "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." 105 | (flet ((seq% (from by length) 106 | (if (eq type 'list) 107 | (loop 108 | for i :from 0 :below length 109 | collecting (+ from (* i by))) 110 | (let+ ((type (cond 111 | (type type) 112 | ((= length 1) (if (typep from 'fixnum) 113 | 'fixnum 114 | (type-of from))) 115 | (t (let ((to (+ from (* by length)))) 116 | (etypecase to 117 | (fixnum (if (typep from 'fixnum) 118 | 'fixnum 119 | 'integer)) 120 | (float (type-of to)) 121 | (t 'rational)))))) 122 | (result (make-array length :element-type type))) 123 | (dotimes (i length) 124 | (setf (aref result i) (coerce (+ from (* i by)) type))) 125 | result)))) 126 | (cond 127 | ((not from) 128 | (seq% (- to (* by (1- length))) by length)) 129 | ((not to) 130 | (seq% from by length)) 131 | ((not length) 132 | (assert (not (zerop by))) 133 | (let* ((range (- to from)) 134 | (by (* (signum range) (signum by) by)) 135 | (length (1+ (floor (/ range by))))) 136 | (seq% from by length))) 137 | ((and length (not by)) 138 | (let ((range (- to from))) 139 | (seq% from (if (zerop range) 140 | 0 141 | (/ range (1- length))) 142 | length))) 143 | (t (error "Only 3 of FROM, TO, LENGTH and BY are needed."))))) 144 | 145 | (defun ivec (end-or-start &optional (end 0 end?) (by 1) strict-direction?) 146 | "Return a vector of fixnums. 147 | 148 | (ivec end) => #(0 ... end-1) (or #(0 ... end+1) when end is negative). 149 | 150 | (ivec start end) => #(start ... end-1) or to end+1 when end is negative. 151 | 152 | When BY is given it determines the increment, adjusted to match the direction unless STRICT-DIRECTION, in which case an error is signalled. " 153 | (check-types (end-or-start end by) fixnum) 154 | (if end? 155 | (let* ((abs-by (abs by)) 156 | (start end-or-start) 157 | (diff (- end start)) 158 | (length (ceiling (abs diff) abs-by)) 159 | (by (aprog1 (* abs-by (signum diff)) 160 | (when strict-direction? 161 | (assert (= it by) () "BY does not match direction.")))) 162 | (element start)) 163 | (aprog1 (make-array length :element-type 'fixnum) 164 | (loop for index below length 165 | do (setf (aref it index) element) 166 | (incf element by)))) 167 | (let* ((end end-or-start) 168 | (abs-end (abs end))) 169 | (aprog1 (make-array abs-end :element-type 'fixnum) 170 | (if (plusp end) 171 | (loop for index below abs-end 172 | do (setf (aref it index) index)) 173 | (loop for index below abs-end 174 | do (setf (aref it index) (- index)))))))) 175 | 176 | ;;; sums and products 177 | 178 | (defgeneric sum (object &key key) 179 | (:documentation "Sum of elements in object. KEY is applied to each 180 | element.") 181 | (:method ((sequence sequence) &key (key #'identity)) 182 | (reduce #'+ sequence :key key)) 183 | (:method ((array array) &key (key #'identity)) 184 | (reduce #'+ (aops:flatten array) :key key))) 185 | 186 | (defgeneric product (object) 187 | (:documentation "Product of elements in object.") 188 | (:method ((sequence sequence)) 189 | (reduce #'* sequence)) 190 | (:method ((array array)) 191 | (reduce #'* (aops:flatten array)))) 192 | 193 | ;;; cumulative sum and product 194 | 195 | (defun similar-element-type (element-type) 196 | "Return a type that is a supertype of ELEMENT-TYPE and is closed under arithmetic operations. May not be the narrowest." 197 | (if (subtypep element-type 'float) 198 | element-type 199 | t)) 200 | 201 | (defun similar-sequence-type (sequence) 202 | "Return type that sequence can be mapped to using arithmetic operations." 203 | (etypecase sequence 204 | (list 'list) 205 | (vector `(simple-array 206 | ,(similar-element-type (array-element-type sequence)) (*))))) 207 | 208 | 209 | (defun cumulative-sum (sequence 210 | &key (result-type (similar-sequence-type sequence))) 211 | "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." 212 | (let ((sum 0)) 213 | (values (map result-type (lambda (element) 214 | (incf sum element)) 215 | sequence) 216 | sum))) 217 | 218 | (defun cumulative-product (sequence 219 | &key (result-type 220 | (similar-sequence-type sequence))) 221 | "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." 222 | (let ((product 1)) 223 | (values (map result-type (lambda (element) 224 | (multf product element)) 225 | sequence) 226 | product))) 227 | 228 | ;;; norms 229 | 230 | (defgeneric l2norm-square (object) 231 | (:documentation "Square of the $L_2$ norm of OBJECT.") 232 | (:method ((sequence sequence)) 233 | (sum sequence :key #'absolute-square))) 234 | 235 | (defun l2norm (object) 236 | "$L_2$ norm of OBJECT." 237 | (sqrt (l2norm-square object))) 238 | 239 | (defun normalize-probabilities (vector 240 | &key 241 | (element-type t) 242 | (result (make-array (length vector) 243 | :element-type element-type))) 244 | "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." 245 | (unless result 246 | (setf result vector) 247 | (let ((result-type (array-element-type result))) 248 | (unless (subtypep element-type result-type) 249 | (setf element-type result-type)))) 250 | (let ((result (aif result it vector)) 251 | (sum (reduce #'+ vector 252 | :key (lambda (element) 253 | (assert (non-negative-real-p element)) 254 | element)))) 255 | (map-into result (lambda (element) (coerce (/ element sum) element-type)) vector))) 256 | 257 | ;;; truncation/rounding 258 | 259 | (defmacro define-rounding-with-offset (name function docstring) 260 | `(defun ,name (number &optional (divisor 1) (offset 0)) 261 | ,docstring 262 | (let+ (((&values quotient remainder) (,function (- number offset) divisor))) 263 | (values (+ offset (* quotient divisor)) remainder)))) 264 | 265 | (define-rounding-with-offset floor* floor 266 | "Find the highest A=I*DIVISOR+OFFSET <= NUMBER, return (values A (- A NUMBER).") 267 | 268 | (define-rounding-with-offset ceiling* ceiling 269 | "Find the lowest A=I*DIVISOR+OFFSET >= NUMBER, return (values A (- A NUMBER).") 270 | 271 | (define-rounding-with-offset round* round 272 | "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.") 273 | 274 | (define-rounding-with-offset truncate* truncate 275 | "Find A=I*DIVISOR+OFFSET that maximizes |A|<=|NUMBER| with the same sign, return (values A (- A NUMBER).") 276 | -------------------------------------------------------------------------------- /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))) 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/matrix.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | (cl:defpackage #:cl-num-utils.matrix 3 | (:use #:cl 4 | #:alexandria 5 | #:anaphora 6 | #:cl-num-utils.elementwise 7 | #:cl-num-utils.num= 8 | #:cl-num-utils.print-matrix 9 | #:cl-num-utils.utilities 10 | #:cl-slice 11 | #:let-plus) 12 | (:export 13 | #:diagonal-vector 14 | #:diagonal-matrix 15 | #:wrapped-matrix 16 | #:lower-triangular-matrix 17 | #:upper-triangular-matrix 18 | #:triangular-matrix 19 | #:hermitian-matrix 20 | #:diagonal-matrix-elements 21 | #:wrapped-matrix-elements 22 | #:transpose)) 23 | 24 | (in-package #:cl-num-utils.matrix) 25 | 26 | (defgeneric diagonal-vector (matrix) 27 | (:documentation "Return the diagonal elements of MATRIX as a vector.") 28 | (:method ((matrix array)) 29 | (let+ (((nrow ncol) (array-dimensions matrix)) 30 | (n (min nrow ncol))) 31 | (aprog1 (aops:make-array-like matrix :dimensions n) 32 | (dotimes (index n) 33 | (setf (aref it index) (aref matrix index index)))))) 34 | (:method (matrix) 35 | (diagonal-vector (aops:as-array matrix)))) 36 | 37 | (defgeneric (setf diagonal-vector) (vector matrix) 38 | (:documentation "Set the diagonal elements of MATRIX using VECTOR.") 39 | (:method ((vector vector) (matrix array)) 40 | (let+ (((nrow ncol) (array-dimensions matrix)) 41 | (n (min nrow ncol))) 42 | (assert (length= vector n)) 43 | (dotimes (index n) 44 | (setf (aref matrix index index) (aref vector index)))) 45 | vector)) 46 | 47 | ;;; utility functions 48 | (defun valid-sparse-type? (type) 49 | "Check if TYPE is a valid type for sparse matrices. Only supertypes and subtypes of NUMBER are allowed." 50 | (or (subtypep type 'number) (subtypep 'number type))) 51 | 52 | (defun ensure-valid-elements (array rank &rest predicates) 53 | "Convert OBJECT to an array, check that it 54 | 55 | 1. has the required rank, 56 | 57 | 2. has a valid sparse element type, and 58 | 59 | 3. that it satisfies PREDICATES. 60 | 61 | Return the array." 62 | (let* ((array (aops:as-array array)) 63 | (type (array-element-type array))) 64 | (assert (valid-sparse-type? type) () 65 | "Array has element-type ~A, which cannot be used for a numeric matrix.") 66 | (assert (= (array-rank array) rank)) 67 | (loop for predicate in predicates 68 | do (assert (funcall predicate array))) 69 | array)) 70 | 71 | (defun zero-like (array) 72 | "Return 0 coerced to the element type of ARRAY. It is assumed that the latter satisfies VALID-SPARSE-TYPE?." 73 | (coerce 0 (array-element-type array))) 74 | 75 | ;;; diagonal matrices 76 | (defstruct diagonal-matrix 77 | "Diagonal matrix. The elements in the diagonal are stored in a vector." 78 | (elements nil :type vector)) 79 | 80 | (defun diagonal-matrix (elements) 81 | (make-diagonal-matrix :elements (ensure-valid-elements elements 1))) 82 | 83 | (define-structure-let+ (diagonal-matrix) elements) 84 | 85 | (defmethod aops:as-array ((diagonal-matrix diagonal-matrix)) 86 | (let+ (((&diagonal-matrix elements) diagonal-matrix) 87 | (n (length elements))) 88 | (aprog1 (aops:make-array-like elements 89 | :dimensions (list n n) 90 | :initial-element 0) 91 | (dotimes (index n) 92 | (setf (aref it index index) (aref elements index)))))) 93 | 94 | (defmethod aops:element-type ((diagonal-matrix diagonal-matrix)) 95 | (array-element-type (diagonal-matrix-elements diagonal-matrix))) 96 | 97 | (defmethod aops:dims ((diagonal-matrix diagonal-matrix)) 98 | (let ((n (length (diagonal-matrix-elements diagonal-matrix)))) 99 | (list n n))) 100 | 101 | ;;; wrapped matrices 102 | (defstruct wrapped-matrix 103 | "A matrix that has some special structure (eg triangular, symmetric/hermitian). ELEMENTS is always a matrix. Not used directly, not exported." 104 | (elements nil :type (array * (* *)) :read-only t)) 105 | 106 | (defmethod aops:element-type ((wrapped-matrix wrapped-matrix)) 107 | (array-element-type (wrapped-matrix-elements wrapped-matrix))) 108 | 109 | (defmethod aops:dims ((wrapped-matrix wrapped-matrix)) 110 | (array-dimensions (wrapped-matrix-elements wrapped-matrix))) 111 | 112 | ;;; triangular matrices 113 | (declaim (inline above-diagonal? below-diagonal?)) 114 | 115 | (defun above-diagonal? (row col) 116 | "Test if element with indexes row and col is (strictly) above the diagonal." 117 | (< row col)) 118 | 119 | (defun below-diagonal? (row col) 120 | "Test if element with indexes row and col is (strictly) below the diagonal." 121 | (> row col)) 122 | 123 | (defmacro define-wrapped-matrix (type elements struct-docstring 124 | (masked-test masked-string) 125 | check-and-convert-elements 126 | regularize-elements) 127 | (let+ (((&with-gensyms matrix stream row col)) 128 | (elements-accessor `(,(symbolicate type '#:-elements) ,matrix))) 129 | `(progn 130 | (defstruct (,type (:include wrapped-matrix)) 131 | ,struct-docstring) 132 | (defun ,type (,elements) 133 | "Create a lower-triangular-matrix." 134 | (,(symbolicate '#:make- type) :elements ,check-and-convert-elements)) 135 | (defmethod aops:as-array ((,matrix ,type)) 136 | (let+ ((,elements ,elements-accessor)) 137 | ,@(splice-awhen regularize-elements 138 | it) 139 | ,elements)) 140 | (defmethod print-object ((,matrix ,type) ,stream) 141 | (print-unreadable-object (,matrix ,stream :type t) 142 | (let ((,elements ,elements-accessor)) 143 | (format ,stream "element-type ~A~%" (aops:element-type ,elements)) 144 | (print-matrix ,elements ,stream 145 | :masked-fn (lambda (,row ,col) 146 | (when (,masked-test ,row ,col) 147 | ,masked-string)))))) 148 | (defmethod slice ((,matrix ,type) &rest slices) 149 | ;; NOTE: certain slices return matrices which preserve special structure. Currently we handle the case when the slice is the same for both dimensions by default, and the matrix is square. 150 | (if (and (not (cdr slices)) (aops:square-matrix? ,matrix)) 151 | (,type (slice ,elements-accessor (car slices) (car slices))) 152 | (apply #'slice (aops:as-array ,matrix) slices)))))) 153 | 154 | (define-wrapped-matrix lower-triangular-matrix elements 155 | "Lower triangular matrix. ELEMENTS in the upper triangle are treated as zero." 156 | (above-diagonal? ".") 157 | (ensure-valid-elements elements 2) 158 | (let+ ((zero (zero-like elements)) 159 | ((nrow ncol) (array-dimensions elements))) 160 | (dotimes (row nrow) 161 | (loop for col from (1+ row) below ncol 162 | do (setf (aref elements row col) zero))))) 163 | 164 | (define-wrapped-matrix upper-triangular-matrix elements 165 | "Upper triangular matrix. ELEMENTS in the lower triangle are treated as zero." 166 | (below-diagonal? ".") 167 | (ensure-valid-elements elements 2) 168 | (let+ ((zero (zero-like elements))) 169 | (dotimes (row (array-dimension elements 0)) 170 | (loop for col from 0 below row 171 | do (setf (aref elements row col) zero))))) 172 | 173 | (deftype triangular-matrix () 174 | "Triangular matrix (either lower or upper)." 175 | '(or lower-triangular-matrix upper-triangular-matrix)) 176 | 177 | ;;; Hermitian matrix 178 | 179 | (define-wrapped-matrix hermitian-matrix elements 180 | "Hermitian/symmetric matrix, with elements stored in the _lower_ triangle. 181 | 182 | Implements _both_ real symmetric and complex Hermitian matrices --- as technically, real symmetric matrices are also Hermitian. Complex symmetric matrices are _not_ implemented as a special matrix type, as they don't have any special properties (eg real eigenvalues, etc)." 183 | (above-diagonal? "*") 184 | (ensure-valid-elements elements 2 #'aops:square-matrix?) 185 | (let+ (((nrow ncol) (array-dimensions elements))) 186 | (dotimes (row nrow) 187 | (loop for col from (1+ row) below ncol 188 | do (setf (aref elements row col) 189 | (conjugate (aref elements col row))))))) 190 | 191 | (defmacro define-elementwise-with-constant 192 | (type 193 | &key (functions '(e2* e2/)) 194 | (elements-accessor (symbolicate type '#:-elements))) 195 | "Define binary elementwise operations for FUNCTION for all subclasses of wrapped-elements." 196 | `(progn 197 | ,@(loop :for function :in functions 198 | :collect 199 | `(defmethod ,function ((a ,type) (b number)) 200 | (,type (,function (,elements-accessor a) b))) 201 | :collect 202 | `(defmethod ,function ((a number) (b ,type)) 203 | (,type (,function a (,elements-accessor b))))))) 204 | 205 | (defmacro define-elementwise-same-class 206 | (type 207 | &key (functions '(e2+ e2- e2*)) 208 | (elements-accessor (symbolicate type '#:-elements))) 209 | "Define binary elementwise operations for FUNCTION for two arguments of the same class." 210 | `(progn 211 | ,@(loop for function in functions collect 212 | `(defmethod ,function ((a ,type) (b ,type)) 213 | (,type (,function (,elements-accessor a) 214 | (,elements-accessor b))))))) 215 | 216 | (defmacro define-elementwise-as-array (type 217 | &key (functions '(e2+ e2- e2*))) 218 | "Define binary elementwise operations for FUNCTION, implemented by converting them to arrays." 219 | `(progn 220 | ,@(loop for function in functions 221 | collect `(defmethod ,function ((a ,type) b) 222 | (,function (aops:as-array a) b)) 223 | collect `(defmethod ,function (a (b ,type)) 224 | (,function a (aops:as-array b)))))) 225 | 226 | (defmacro define-elementwise-univariate 227 | (type &key (functions '(e1- e1/ eexp e1log esqrt)) 228 | (elements-accessor (symbolicate type '#:-elements))) 229 | "Define unary elementwise operations for FUNCTION for all subclasses of wrapped-elements." 230 | `(progn 231 | ,@(loop :for function :in functions 232 | :collect 233 | `(defmethod ,function ((a ,type)) 234 | (,type (,function (,elements-accessor a))))))) 235 | 236 | (define-elementwise-as-array wrapped-matrix) 237 | 238 | (define-elementwise-with-constant lower-triangular-matrix) 239 | (define-elementwise-with-constant upper-triangular-matrix) 240 | (define-elementwise-with-constant hermitian-matrix) 241 | (define-elementwise-with-constant diagonal-matrix) 242 | 243 | (define-elementwise-same-class lower-triangular-matrix) 244 | (define-elementwise-same-class upper-triangular-matrix) 245 | (define-elementwise-same-class hermitian-matrix) 246 | (define-elementwise-same-class diagonal-matrix) 247 | 248 | (define-elementwise-univariate lower-triangular-matrix) 249 | (define-elementwise-univariate upper-triangular-matrix) 250 | (define-elementwise-univariate hermitian-matrix) 251 | (define-elementwise-univariate diagonal-matrix) 252 | 253 | (defmethod num= ((a wrapped-matrix) (b wrapped-matrix) 254 | &optional (tolerance *num=-tolerance*)) 255 | (and (equal (type-of a) (type-of b)) 256 | (num= (aops:as-array a) (aops:as-array b) tolerance))) 257 | 258 | (defmethod num= ((a diagonal-matrix) (b diagonal-matrix) 259 | &optional (tolerance *num=-tolerance*)) 260 | (num= (diagonal-matrix-elements a) (diagonal-matrix-elements b) tolerance)) 261 | 262 | 263 | ;;; transpose 264 | 265 | (defgeneric transpose (array) 266 | (:documentation "Transpose.") 267 | (:method ((array array)) 268 | (let+ (((nrow ncol) (array-dimensions array))) 269 | (aprog1 (aops:make-array-like array :dimensions (list ncol nrow)) 270 | (dotimes (row nrow) 271 | (dotimes (col ncol) 272 | (setf (aref it col row) (aref array row col))))))) 273 | (:method ((matrix lower-triangular-matrix)) 274 | (upper-triangular-matrix 275 | (transpose (lower-triangular-matrix-elements matrix)))) 276 | (:method ((matrix upper-triangular-matrix)) 277 | (lower-triangular-matrix 278 | (transpose (upper-triangular-matrix-elements matrix)))) 279 | (:method ((matrix hermitian-matrix)) 280 | (if (subtypep (aops:element-type matrix) 'real) 281 | matrix 282 | (hermitian-matrix (transpose (aops:as-array matrix))))) 283 | (:method ((diagonal diagonal-matrix)) 284 | diagonal)) 285 | -------------------------------------------------------------------------------- /src/interval.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (defpackage #:cl-num-utils.interval 4 | (:use #:cl 5 | #:alexandria 6 | #:anaphora 7 | #:cl-num-utils.num= 8 | #:cl-num-utils.utilities 9 | #:let-plus) 10 | (:export 11 | #:left 12 | #:open-left? 13 | #:right 14 | #:open-right? 15 | #:&interval 16 | #:interval 17 | #:finite-interval 18 | #:plusinf-interval 19 | #:minusinf-interval 20 | #:real-line 21 | #:plusminus-interval 22 | #:interval-length 23 | #:interval-midpoint 24 | #:in-interval? 25 | #:extend-interval 26 | #:extendf-interval 27 | #:interval-hull 28 | #:relative 29 | #:spacer 30 | #:split-interval 31 | #:shrink-interval 32 | #:grid-in 33 | #:subintervals-in 34 | #:shift-interval)) 35 | 36 | (in-package #:cl-num-utils.interval) 37 | 38 | ;;; TODO: rewrite interface 39 | ;;; TODO: open/closed, general accessors LEFT, RIGHT, CLOSED-LEFT? CLOSED-RIGHT? 40 | 41 | ;;; basic interval definitions and interface 42 | 43 | (defgeneric left (interval) 44 | (:documentation "Left endpoint of interval.")) 45 | 46 | (defgeneric open-left? (interval) 47 | (:documentation "True iff the left endpoint of the interval is open.")) 48 | 49 | (defgeneric right (interval) 50 | (:documentation "Right endpoint of interval.")) 51 | 52 | (defgeneric open-right? (interval) 53 | (:documentation "True iff the right endpoint of the interval is open.")) 54 | 55 | (eval-when (:compile-toplevel :load-toplevel :execute) 56 | (define-let+-expansion (&interval (left right) :value-var value :body-var body) 57 | "LET+ expansion for interval endpoints. If given a list of two values, 58 | the second value is an indicator for whether the endpoint is open." 59 | (let+ (((left &optional (open-left? nil left-open-p)) (ensure-list left)) 60 | ((right &optional (open-right? nil right-open-p)) (ensure-list right))) 61 | `(let+ ((,left (left ,value)) 62 | ,@(splice-when left-open-p `(,open-left? (open-left? ,value))) 63 | (,right (right ,value)) 64 | ,@(splice-when right-open-p `(,open-right? (open-right? ,value)))) 65 | ,@body)))) 66 | 67 | ;;; mix-in classes. used as building blocks, none of these are exported. 68 | 69 | (defclass interval/finite-left () 70 | ((left :type real :initarg :left :reader left) 71 | (open-left? :type boolean :initarg :open-left? :reader open-left?)) 72 | (:documentation "Interval with left endpoint.")) 73 | 74 | (defclass interval/finite-right () 75 | ((right :type real :initarg :right :reader right) 76 | (open-right? :type boolean :initarg :open-right? :reader open-right?)) 77 | (:documentation "Interval with right endpoint.")) 78 | 79 | (defclass interval/infinite-left () 80 | () 81 | (:documentation "Left endpoint is -∞.")) 82 | 83 | (defmethod left ((interval interval/infinite-left)) 84 | :minusinf) 85 | 86 | (defmethod open-left? ((interval interval/infinite-left)) 87 | t) 88 | 89 | (defclass interval/infinite-right () 90 | () 91 | (:documentation "Right endpoint is ∞.")) 92 | 93 | (defmethod right ((interval interval/infinite-right)) 94 | :plusinf) 95 | 96 | (defmethod open-right? ((interval interval/infinite-right)) 97 | t) 98 | 99 | (defgeneric print-left-endpoint (interval stream) 100 | (:method ((interval interval/finite-left) stream) 101 | (let+ (((&slots-r/o left open-left?) interval)) 102 | (format stream "~C~A" (if open-left? #\( #\[) left))) 103 | (:method ((interval interval/infinite-left) stream) 104 | (format stream "(-∞"))) 105 | 106 | (defgeneric print-right-endpoint (interval stream) 107 | (:method ((interval interval/finite-right) stream) 108 | (let+ (((&slots-r/o right open-right?) interval)) 109 | (format stream "~A~C" right (if open-right? #\) #\])))) 110 | (:method ((interval interval/infinite-right) stream) 111 | (format stream "∞)"))) 112 | 113 | 114 | ;;; interval types 115 | 116 | (defclass interval () 117 | () 118 | (:documentation "Abstract superclass for all intervals.")) 119 | 120 | (defmethod print-object ((interval interval) stream) 121 | (print-unreadable-object (interval stream :type t) 122 | (print-left-endpoint interval stream) 123 | (format stream ",") 124 | (print-right-endpoint interval stream))) 125 | 126 | (defclass finite-interval (interval interval/finite-left interval/finite-right) 127 | () 128 | (:documentation "Interval with finite endpoints.")) 129 | 130 | (defmethod initialize-instance :after ((interval finite-interval) 131 | &key &allow-other-keys) 132 | (let+ (((&slots-r/o left right open-left? open-right?) interval)) 133 | (cond 134 | ((> left right) (error "Intervals with LEFT > RIGHT are not allowed.")) 135 | ((= left right) (assert (not (or open-left? open-right?)) () 136 | "Zero-length intervals cannot be (half-)open."))))) 137 | 138 | (defclass plusinf-interval (interval interval/finite-left interval/infinite-right) 139 | () 140 | (:documentation "Interval from LEFT to ∞.")) 141 | 142 | (defclass minusinf-interval (interval interval/infinite-left interval/finite-right) 143 | () 144 | (:documentation "Interval from -∞ to RIGHT.")) 145 | 146 | (defclass real-line (interval interval/infinite-left interval/infinite-right) 147 | () 148 | (:documentation "Representing the real line (-∞,∞).")) 149 | 150 | (defmethod num= ((a real-line) (b real-line) 151 | &optional (tolerance *num=-tolerance*)) 152 | (declare (ignore tolerance)) 153 | t) 154 | 155 | (defmethod num= ((a finite-interval) (b finite-interval) 156 | &optional (tolerance *num=-tolerance*)) 157 | (let+ (((&interval (al alo?) (ar aro?)) a) 158 | ((&interval (bl blo?) (br bro?)) b)) 159 | (and (num= al bl tolerance) 160 | (num= ar br tolerance) 161 | (eq alo? blo?) 162 | (eq aro? bro?)))) 163 | 164 | 165 | ;;; interval creation interface 166 | 167 | (declaim (inline interval)) 168 | (defun interval (left right &key open-left? open-right?) 169 | "Create an INTERVAL." 170 | (xreal:with-template (? left right) 171 | (cond 172 | ((? real real) (make-instance 'finite-interval :left left :right right 173 | :open-left? open-left? 174 | :open-right? open-right?)) 175 | ((? real :plusinf) (make-instance 'plusinf-interval :left left 176 | :open-left? open-left?)) 177 | ((? :minusinf real) (make-instance 'minusinf-interval :right right 178 | :open-right? open-right?)) 179 | ((? :minusinf :plusinf) (make-instance 'real-line)) 180 | (t (error "Invalid interval specification."))))) 181 | 182 | (defun plusminus-interval (center half-width 183 | &key open-left? (open-right? open-left?)) 184 | "A symmetric interval around CENTER." 185 | (assert (plusp half-width)) 186 | (make-instance 'finite-interval 187 | :left (- center half-width) :open-left? open-left? 188 | :right (+ center half-width) :open-right? open-right?)) 189 | 190 | 191 | ;;; interval 192 | 193 | ;;; FIXME code below dows not handle open/infinite endpoints 194 | 195 | (defun interval-length (interval) 196 | "Difference between left and right." 197 | (- (right interval) (left interval))) 198 | 199 | (defun interval-midpoint (interval &optional (alpha 1/2)) 200 | "Convex combination of left and right, with alpha (defaults to 0.5) 201 | weight on right." 202 | (let+ (((&interval left right) interval)) 203 | (+ (* (- 1 alpha) left) (* alpha right)))) 204 | 205 | (defun in-interval? (interval number) 206 | "Test if NUMBER is in INTERVAL (which can be NIL, designating the empty 207 | set)." 208 | (and interval 209 | (let+ (((&interval left right) interval)) 210 | (<= left number right)))) 211 | 212 | (defgeneric extend-interval (interval object) 213 | (:documentation "Return an interval that includes INTERVAL and OBJECT. NIL 214 | stands for the empty set.") 215 | (:method ((interval null) (object null)) 216 | nil) 217 | (:method ((interval null) (number real)) 218 | (interval number number)) 219 | (:method ((interval interval) (number real)) 220 | (let+ (((&interval left right) interval)) 221 | (if (<= left number right) 222 | interval 223 | (interval (min left number) (max right number))))) 224 | (:method (interval (object interval)) 225 | (let+ (((&interval left right) object)) 226 | (extend-interval (extend-interval interval left) right))) 227 | (:method (interval (list list)) 228 | (reduce #'extend-interval list :initial-value interval)) 229 | (:method (interval (array array)) 230 | (reduce #'extend-interval (aops:flatten array) :initial-value interval))) 231 | 232 | (defmacro extendf-interval (place object &environment environment) 233 | "Apply EXTEND-INTERVAL on PLACE using OBJECT." 234 | (let+ (((&with-gensyms extended)) 235 | ((&values dummies vals new setter getter) 236 | (get-setf-expansion place environment)) 237 | ((new . rest) new)) 238 | (assert (not rest) () "Can't expand this.") 239 | `(let* (,@(mapcar #'list dummies vals) 240 | (,new ,getter) 241 | (,extended (extend-interval ,new ,object))) 242 | (if (eq ,extended ,new) 243 | ,extended 244 | (prog1 (setf ,new ,extended) 245 | ,setter))))) 246 | 247 | (defun interval-hull (object) 248 | "Return the smallest connected interval that contains (elements in) OBJECT." 249 | (extend-interval nil object)) 250 | 251 | ;;; Interval manipulations 252 | 253 | (defstruct (relative (:constructor relative (fraction))) 254 | "Relative sizes are in terms of width." 255 | ;; MAKE-RELATIVE is not exported 256 | (fraction nil :type (real 0) :read-only t)) 257 | 258 | (defstruct (spacer (:constructor spacer (&optional weight))) 259 | "Spacers divide the leftover portion of an interval." 260 | (weight 1 :type (real 0) :read-only t)) 261 | 262 | (defun split-interval (interval divisions) 263 | "Return a vector of subintervals (same length as DIVISIONS), splitting the 264 | interval using the sequence DIVISIONS, which can be nonnegative real 265 | numbers (or RELATIVE specifications) and SPACERs which divide the leftover 266 | proportionally. If there are no spacers and the divisions don't fill up the 267 | interval, and error is signalled." 268 | (let+ ((length (interval-length interval)) 269 | (spacers 0) 270 | (absolute 0) 271 | ((&flet absolute (x) 272 | (incf absolute x) 273 | x)) 274 | (divisions 275 | (map 'vector 276 | (lambda (div) 277 | (etypecase div 278 | (real (absolute div)) 279 | (relative (absolute (* length (relative-fraction div)))) 280 | (spacer (incf spacers (spacer-weight div)) 281 | div))) 282 | divisions)) 283 | (rest (- length absolute))) 284 | (when (minusp rest) 285 | (error "Length of divisions exceeds the width of the interval.")) 286 | (assert (not (and (zerop spacers) (plusp rest))) () 287 | "Divisions don't use up the interval.") 288 | (let* ((left (left interval)) 289 | (spacer-unit (/ rest spacers))) 290 | (map 'vector (lambda (div) 291 | (let* ((step (etypecase div 292 | (number div) 293 | (spacer (* spacer-unit 294 | (spacer-weight div))))) 295 | (right (+ left step))) 296 | (prog1 (interval left right) 297 | (setf left right)))) 298 | divisions)))) 299 | 300 | (defun shrink-interval (interval left 301 | &optional (right left) 302 | (check-flip? t)) 303 | "Shrink interval by given magnitudes (which may be REAL or RELATIVE). When 304 | check-flip?, the result is checked for endpoints being in a different order 305 | than the original. Negative LEFT and RIGHT extend the interval." 306 | (let+ (((&interval l r) interval) 307 | (d (- r l)) 308 | ((&flet absolute (ext) 309 | (etypecase ext 310 | (relative (* d (relative-fraction ext))) 311 | (real ext)))) 312 | (l2 (+ l (absolute left))) 313 | (r2 (- r (absolute right)))) 314 | (when check-flip? 315 | (assert (= (signum d) (signum (- r2 l2))))) 316 | (interval l2 r2))) 317 | 318 | (defun grid-in (interval size &optional (sequence-type nil sequence-type?)) 319 | "Return an arithmetic sequence of the given size (length) between the 320 | endpoints of the interval. The endpoints of the sequence coincide with the 321 | respective endpoint of the interval iff it is closed. RESULT-TYPE determines 322 | the result type (eg list), if not given it is a simple-array (of rank 1), 323 | narrowing to the appropriate float type or fixnum if possible." 324 | (check-type interval finite-interval) 325 | (check-type size (integer 2)) 326 | (let+ (((&interval (left open-left?) (right open-right?)) interval) 327 | ;; correction calculations take care of numeric contagion 328 | (left-correction (if open-left? 1/2 0)) 329 | (right-correction (if open-right? 1/2 0)) 330 | (size-1 (1- size)) 331 | (step (/ (- right left) 332 | (+ size-1 left-correction right-correction))) 333 | (left (+ left (* step left-correction))) 334 | (right (- right (* step right-correction))) 335 | ;; 336 | (step (/ (- right left) size-1)) 337 | (element-type (cond 338 | ((and sequence-type? (subtypep sequence-type 'array)) 339 | (let+ (((&ign &optional (element-type t) &rest &ign) 340 | sequence-type)) 341 | element-type)) 342 | ((floatp step) (type-of step)) 343 | ((and (fixnum? left) (fixnum? right) (fixnum? step)) 344 | 'fixnum) 345 | (t t))) 346 | (sequence-type (if sequence-type? 347 | sequence-type 348 | `(simple-array ,element-type (*))))) 349 | (generate-sequence sequence-type size 350 | (let ((index 0)) 351 | (lambda () 352 | (prog1 (if (= index size-1) 353 | right 354 | (+ left (* index step))) 355 | (incf index))))))) 356 | 357 | (defun subintervals-in (interval count &optional (mid-open-right? t)) 358 | "Return INTERVAL evenly divided into COUNT subintervals as a vector. When MID-OPEN-RIGHT?, subintervals in the middle are open on the right and closed on the left, otherwise the opposite; openness of endpoints on the edge follows INTERVAL." 359 | (check-type count (integer 1)) 360 | (check-type interval finite-interval) 361 | (let+ (((&interval (left open-left?) (right open-right?)) interval) 362 | (mid-open-left? (not mid-open-right?)) 363 | (l left)) 364 | (aprog1 (make-array count) 365 | (loop for index below count 366 | do (let* ((next (1+ index)) 367 | (end? (= next count)) 368 | (r (if end? 369 | right 370 | (lerp (/ next count) left right)))) 371 | (setf (aref it index) (interval l r 372 | :open-left? (if (zerop index) 373 | open-left? 374 | mid-open-left?) 375 | :open-right? (if end? 376 | open-right? 377 | mid-open-right?)) 378 | l r)))))) 379 | 380 | (defgeneric shift-interval (interval offset) 381 | (:method ((interval finite-interval) (offset real)) 382 | (let+ (((&interval (left open-left?) (right open-right?)) interval)) 383 | (interval (+ left offset) (+ right offset) 384 | :open-left? open-left? :open-right? open-right?)))) 385 | -------------------------------------------------------------------------------- /tests/statistics.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:cl-num-utils-tests) 4 | 5 | (defsuite statistics-tests (tests)) 6 | 7 | ;;; testing cental moments 8 | 9 | (defun precise-central-moments (sequence) 10 | "First 4 central moments, calculated using rationals, returned as four values, normalized by the length of the sequence. 11 | 12 | Slow, but useful for testing as it does not suffer from approximation error." 13 | (let+ ((vector (map 'vector #'rational sequence)) 14 | (n (length vector)) 15 | (mean (/ (reduce #'+ vector) n)) 16 | ((&flet central-m (degree) 17 | (/ (reduce #'+ vector 18 | :key (lambda (v) 19 | (expt (- v mean) degree))) 20 | n)))) 21 | (values mean (central-m 2) (central-m 3) (central-m 4)))) 22 | 23 | (defun precise-weighted-central-moments (sequence weights) 24 | "First 4 weighted central moments, calculated using rationals, returned as four values, normalized by the length of the sequence. 25 | 26 | Slow, but useful for testing as it does not suffer from approximation error." 27 | (assert (length= sequence weights)) 28 | (let+ ((vector (map 'vector #'rational sequence)) 29 | (weights (map 'vector #'rational weights)) 30 | (w (reduce #'+ weights)) 31 | (mean (/ (reduce #'+ (map 'vector #'* vector weights)) w)) 32 | ((&flet central-m (degree) 33 | (/ (reduce #'+ (map 'vector (lambda (v w) 34 | (* w (expt (- v mean) degree))) 35 | vector weights)) 36 | w)))) 37 | (values mean (central-m 2) (central-m 3) (central-m 4)))) 38 | 39 | ;;; randomized tests 40 | 41 | (defun random-floats (n mean &optional (element-type 'double-float)) 42 | "Return a N-element vector of random floats (with given ELEMENT-TYPE). A uniform random number from either [-1,0] or [0,3] (with equal probability) is added to MEAN, which ensures nonzero third and fourth central moments. Higher abolute value of MEAN makes the calculation of higher central moments more ill-conditioned when using floats." 43 | (let ((mean (coerce mean element-type)) 44 | (one (coerce 1 element-type))) 45 | (aops:generate* element-type 46 | (lambda () 47 | (let ((v (random one))) 48 | (if (zerop (random 2)) 49 | (- mean v) 50 | (+ mean (* 3 v))))) 51 | n))) 52 | 53 | (defun random-weights (n range &optional (element-type 'double-float)) 54 | "Random weights between (exp 1) and (exp (1+ range)), with given element-type." 55 | (aops:generate* element-type (let ((range (coerce range element-type))) 56 | (lambda () 57 | (exp (1+ (random range))))) 58 | n)) 59 | 60 | (defun test-moments (n mean &optional (element-type 'double-float)) 61 | "Test that moments calculated precisely and with accumulators are equal." 62 | (let+ ((v (random-floats n mean element-type)) 63 | ((&values m-p m2-p m3-p m4-p) (precise-central-moments v)) 64 | ((&accessors-r/o mean central-m2 central-m3 central-m4) 65 | (central-sample-moments v :degree 4)) 66 | (*num=-tolerance* 1e-8)) 67 | (assert-equality #'num= mean m-p) 68 | (assert-equality #'num= central-m2 m2-p) 69 | (assert-equality #'num= central-m3 m3-p) 70 | (assert-equality #'num= central-m4 m4-p))) 71 | 72 | (defun test-weighted-moments (n mean &key (weight-range 4) (element-type 'double-float)) 73 | "Test that moments calculated precisely and with accumulators are equal." 74 | (let+ ((v (random-floats n mean element-type)) 75 | (w (random-weights n weight-range element-type)) 76 | ((&values m-p m2-p m3-p m4-p) (precise-weighted-central-moments v w)) 77 | ((&accessors-r/o mean central-m2 central-m3 central-m4) 78 | (central-sample-moments v :degree 4 :weights w)) 79 | (*num=-tolerance* 1e-8)) 80 | (assert-equality #'num= mean m-p) 81 | (assert-equality #'num= central-m2 m2-p) 82 | (assert-equality #'num= central-m3 m3-p) 83 | (assert-equality #'num= central-m4 m4-p))) 84 | 85 | (deftest central-moments-test1 (statistics-tests) 86 | (test-moments 1000 0) 87 | (test-moments 1000 10) 88 | (test-moments 1000 100) 89 | (test-moments 1000 1000000)) 90 | 91 | (deftest central-moments-test2 (statistics-tests) 92 | (test-weighted-moments 10 0) 93 | (test-weighted-moments 1000 10) 94 | (test-weighted-moments 1000 100) 95 | (test-weighted-moments 1000 1000000)) 96 | 97 | (defun test-pooled-moments (n mean &optional (element-type 'double-float)) 98 | (let* ((v (random-floats (* 2 n) mean element-type)) 99 | (v1 (subseq v 0 n)) 100 | (v2 (subseq v n nil)) 101 | (m (central-sample-moments v :degree 4)) 102 | (m1 (central-sample-moments v1 :degree 4)) 103 | (m2 (central-sample-moments v2 :degree 4)) 104 | (m12 (pool m1 m2)) 105 | (*num=-tolerance* 1e-8)) 106 | (assert-equality #'num= (mean m) (mean m12)))) 107 | 108 | (deftest pooled-moments-test1 (statistics-tests) 109 | (test-pooled-moments 1000 0) 110 | (test-pooled-moments 1000 10) 111 | (test-pooled-moments 1000 100) 112 | (test-pooled-moments 1000 1000000)) 113 | 114 | ;; (addtest (statistics-tests) 115 | ;; test-ratio 116 | ;; (let+ ((v (map1 #'bit-to-boolean #*000011111)) 117 | ;; ((&values ratio acc) (sample-ratio v))) 118 | ;; (ensure-same ratio 5/9) 119 | ;; (ensure-same (tally acc) 9))) 120 | 121 | (deftest test-invalid-types (statistics-tests) 122 | (assert-condition error (add (central-sample-moments) 'foo)) 123 | (assert-condition error (add (central-sample-moments) #(1 2 3))) 124 | ;; (ensure-error (add (autocovariance-accumulator 9) 'foo)) 125 | ;; (ensure-error (add (autocovariance-accumulator 9) #(1 2 3))) 126 | ) 127 | 128 | (deftest test-mean (statistics-tests) 129 | (assert-equalp 2 (mean (iota 5))) 130 | (assert-equalp 4 (mean (iota 9)))) 131 | 132 | (deftest test-variance (statistics-tests) 133 | (assert-equalp 15/2 (variance (iota 9))) 134 | (assert-equalp 35 (variance (iota 20)))) 135 | 136 | (deftest pooled-moments-test (statistics-tests) 137 | (let ((v #(62.944711253834164d0 81.15843153081796d0 25.397393118645773d0 138 | 82.67519197788647d0 26.471834961609876d0 19.50812790113414d0 139 | 55.69965251750717d0 9.376334465151004d0 91.50142635930303d0 140 | 92.97771145772332d0 31.522629341026608d0 94.11859332177082d0 141 | 91.43334482781893d0 97.07515698488776d0 60.05604715628141d0 142 | 28.377247312878072d0 84.35221790928993d0 83.14710996278352d0 143 | 58.44153198534443d0 91.89848934771322d0))) 144 | (assert-equality #'num= (central-sample-moments v :degree 4) 145 | (pool (central-sample-moments (subseq v 0 7) :degree 4) 146 | (central-sample-moments (subseq v 7) :degree 4))))) 147 | 148 | ;; (addtest (statistics-tests) 149 | ;; sse-off-center-test 150 | ;; (let+ ((a (ia 9)) 151 | ;; (b (ia* 7 19)) 152 | ;; ((&flet sse2 (seq center) 153 | ;; (sum seq :key (lambda (x) (expt (- x center) 2))))) 154 | ;; (*lift-equality-test* #'==)) 155 | ;; (assert-equality (sse a 1.1) (sse2 a 1.1)) 156 | ;; (assert-equality (sse b 1.1) (sse2 b 1.1)) 157 | ;; (assert-equality (sse a pi) (sse2 a pi)))) 158 | 159 | ;; (addtest (statistics-tests) 160 | ;; test-array-mean 161 | ;; (let+ ((v1 (ia 6)) 162 | ;; (v2 (e+ v1 3)) 163 | ;; (v3 (e+ v1 5)) 164 | ;; (vectors (vector v1 v2 v3)) 165 | ;; (vm (e+ v1 8/3)) 166 | ;; ((&flet v->a (v) 167 | ;; (displace-array v '(2 3)))) 168 | ;; (am (v->a vm)) 169 | ;; (*lift-equality-test* #'==)) 170 | ;; (assert-equality (mean vectors) vm) 171 | ;; (assert-equality (mean (map 'vector #'v->a vectors)) am) 172 | ;; (ensure-error (mean (list v1 am))))) 173 | 174 | ;; (defun naive-weighted-variance (sample weights) 175 | ;; "Calculate weighted variance (and mean, returned as the second value) using 176 | ;; the naive method." 177 | ;; (let* ((sw (sum weights)) 178 | ;; (mean (/ (reduce #'+ (map 'vector #'* sample weights)) sw)) 179 | ;; (variance (/ (reduce #'+ 180 | ;; (map 'vector 181 | ;; (lambda (s w) (* (expt (- s mean) 2) w)) 182 | ;; sample weights)) 183 | ;; (1- sw)))) 184 | ;; (values variance mean))) 185 | 186 | ;; (addtest (statistics-tests) 187 | ;; test-weighted 188 | ;; (let ((s1 #(1 2 3)) 189 | ;; (w1 #(4 5 6)) 190 | ;; (*lift-equality-test* #'==) 191 | ;; (s2 (random-vector 50 'double-float)) 192 | ;; (w2 (random-vector 50 'double-float))) 193 | ;; (assert-equality (naive-weighted-variance s1 w1) (weighted-variance s1 w1)) 194 | ;; (assert-equality (naive-weighted-variance s2 w2) (weighted-variance s2 w2) 195 | ;; :test (lambda (x y) 196 | ;; (< (/ (abs (- x y)) 197 | ;; (max 1 (abs x) (abs y))) 198 | ;; 1d-5))) 199 | ;; (assert-equality (second (multiple-value-list (weighted-variance s1 w1))) 200 | ;; (weighted-mean s1 w1)))) 201 | 202 | ;; (defparameter *a* (let ((a (covariance-accumulator))) 203 | ;; (add a (cons 0 0)) 204 | ;; (add a (cons 1 1)) 205 | ;; (add a (cons 2 2)) 206 | ;; a)) 207 | 208 | ;; (addtest (statistics-tests) 209 | ;; test-covariance 210 | ;; (assert-equality (covariance-xy (ia 3) (ia 3)) (variance (ia 3))) 211 | ;; (assert-equality (covariance-xy #(2 3 5) #(7 11 13)) (float 13/3 1d0))) 212 | 213 | ;; (addtest (statistics-tests) 214 | ;; test-autocovariance 215 | ;; (let+ ((n 200) 216 | ;; (a (generate-array 200 (curry #'random 1d0))) 217 | ;; ((&flet lagged (function lag) 218 | ;; (funcall function (subseq a 0 (- n lag)) (subseq a lag)))) 219 | ;; ((&flet cov (lag) (lagged #'covariance-xy lag))) 220 | ;; ((&flet corr (lag) (lagged #'correlation-xy lag))) 221 | ;; ((&values acv acc) (autocovariances a 3)) 222 | ;; (#(c1 c2 c3) acv) 223 | ;; (#(r1 r2 r3) (autocorrelations acc)) 224 | ;; (*lift-equality-test* #'==)) 225 | ;; (assert-equality c1 (cov 1)) 226 | ;; (assert-equality c2 (cov 2)) 227 | ;; (assert-equality c3 (cov 3)) 228 | ;; (assert-equality r1 (corr 1)) 229 | ;; (assert-equality r2 (corr 2)) 230 | ;; (assert-equality r3 (corr 3)) 231 | ;; (assert-equality (autocorrelations a 3) (autocorrelations acc 3)) 232 | ;; (assert-equality (lags acc) 3))) 233 | 234 | ;; (addtest (statistics-tests) 235 | ;; test-pool 236 | ;; (let* ((n 100) 237 | ;; (vector (generate-array (* 2 n) (curry #'random 1d0) 'double-float)) 238 | ;; (acc1 (sweep 'sse (subseq vector 0 n))) 239 | ;; (acc2 (sweep 'sse (subseq vector n))) 240 | ;; (acc (sweep 'sse vector)) 241 | ;; (acc-pooled (pool acc1 acc2)) 242 | ;; (*lift-equality-test* #'==)) 243 | ;; (assert-equality acc acc-pooled))) 244 | 245 | (deftest quantiles (statistics-tests) 246 | (let ((sample #(0.0 1.0)) 247 | (quantiles (numseq 0 1 :length 11 :type 'double-float)) 248 | (weights #(1 1)) 249 | (expected-xs #(0.0 0.0 0.0 0.1 0.3 0.5 0.7 0.9 1.0 1.0 1.0))) 250 | (assert-equality #'num= expected-xs 251 | (map 'vector (curry #'quantile sample) quantiles)) 252 | (assert-equality #'num= expected-xs 253 | (quantiles sample quantiles)) 254 | (assert-equality #'num= expected-xs 255 | (weighted-quantiles sample weights quantiles)))) 256 | 257 | (deftest quantile-probabilities (statistics-tests) 258 | (let* ((n 10) 259 | (sample (sort (aops:generate (lambda () (random (* n 2))) n) #'<)) 260 | (empirical-quantile-probabilities n)) 261 | (assert-equalp sample 262 | (quantiles sample (empirical-quantile-probabilities 263 | (length sample)))))) 264 | 265 | ;; (addtest (statistics-tests) 266 | ;; (let+ ((end 5) 267 | ;; (index 0) ; to make sure we have 1 of each 268 | ;; (pairs (generate-array 100 269 | ;; (lambda () 270 | ;; (prog1 (at (random 100d0) 271 | ;; (if (< index end) 272 | ;; index 273 | ;; (random end))) 274 | ;; (incf index))))) 275 | ;; (acc #'mean-sse-accumulator) 276 | ;; (result (sweep (sparse-accumulator-array 1 acc) pairs)) 277 | ;; (*lift-equality-test* #'==) 278 | ;; ((&flet sparse-acc (pairs accumulator &rest s) 279 | ;; "For testing." 280 | ;; (map nil (lambda+ ((&structure at- object subscripts)) 281 | ;; (when (equal s subscripts) 282 | ;; (add accumulator object))) 283 | ;; pairs) 284 | ;; (when (plusp (tally accumulator)) 285 | ;; accumulator))) 286 | ;; (array1 (iter 287 | ;; (for i below end) 288 | ;; (collect (sparse-acc pairs (funcall acc) i) 289 | ;; :result-type vector))) 290 | ;; ((&values array2 offset) (as-array result))) 291 | ;; (assert-equality (limits result) `((0 . ,end))) 292 | ;; (assert-equality offset '(0)) 293 | ;; (assert-equality array1 array2) 294 | ;; (loop for i below end do 295 | ;; (assert-equality (ref result i) (aref array1 i))))) 296 | 297 | ;; (addtest (statistics-tests) 298 | ;; subranges 299 | ;; (let+ (((&flet random-ranges (n &key (max 200) (order? t)) 300 | ;; (generate-array n (lambda () 301 | ;; (let ((start (random max)) 302 | ;; (end (random max))) 303 | ;; (when (and order? (> start end)) 304 | ;; (rotatef start end)) 305 | ;; (cons start end)))))) 306 | ;; ((&flet assemble-range (subranges index-list) 307 | ;; (unless index-list 308 | ;; (return-from assemble-range nil)) 309 | ;; (iter 310 | ;; (with start) 311 | ;; (with end) 312 | ;; (for index :in index-list) 313 | ;; (for subrange := (aref subranges index)) 314 | ;; (for previous-subrange :previous subrange :initially nil) 315 | ;; (if (first-iteration-p) 316 | ;; (setf start (car subrange)) 317 | ;; (assert (= (car subrange) (cdr previous-subrange)))) 318 | ;; (setf end (cdr subrange)) 319 | ;; (finally 320 | ;; (return (cons start end))))))) 321 | ;; (loop 322 | ;; repeat 100000 do 323 | ;; (let+ ((ranges (random-ranges 10 :order? nil)) 324 | ;; ((&values subranges index-lists) (subranges ranges))) 325 | ;; (iter 326 | ;; (for index-list :in-vector index-lists) 327 | ;; (for range :in-vector ranges) 328 | ;; (for assembled-range := (assemble-range subranges index-list)) 329 | ;; (for match? := (if assembled-range 330 | ;; (equal range assembled-range) 331 | ;; (>= (car range) (cdr range)))) 332 | ;; (unless match? 333 | ;; (format *error-output* "mismatch: range ~A assembled to ~A" 334 | ;; range assembled-range)) 335 | ;; (ensure match?)))))) 336 | 337 | ;; (addtest (statistics-tests) 338 | ;; (let ((ranges #((20 . 40) (60 . 120) (100 . 180))) 339 | ;; (shadow-ranges '((0 . 200))) 340 | ;; (*lift-equality-test* #'equalp)) 341 | ;; (assert-equality (subranges ranges :shadow-ranges shadow-ranges) 342 | ;; (values #((0 . 20) (20 . 40) (40 . 60) (60 . 100) (100 . 120) 343 | ;; (120 . 180) (180 . 200)) 344 | ;; #((1) (3 4) (4 5)))))) 345 | 346 | ;; (addtest (statistics-tests) 347 | ;; histogram-test 348 | ;; (let ((histogram (histogram-accumulator (even-bins 2 -1))) 349 | ;; (*lift-equality-test* #'==)) 350 | ;; (add histogram 0) 351 | ;; (add histogram 0.5) 352 | ;; (loop repeat 3 do (add histogram 1.5)) 353 | ;; ;; (assert-equality (total-frequency histogram) 5) 354 | ;; (assert-equality (ref histogram 0) 2) 355 | ;; (assert-equality (ref histogram 1) 3) 356 | ;; (assert-equality (ref histogram -7) 0) 357 | ;; (ensure-error (add histogram '(0 0))) 358 | ;; (assert-equality (limits histogram) '((0 . 2))) 359 | ;; (assert-equality (location-limits histogram) (list (interval -1 5))))) 360 | 361 | ;; (addtest (statistics-tests) 362 | ;; histogram-test2 363 | ;; (let ((histogram (histogram1 '(1 2 3 2 3 3) (integer-bins)))) 364 | ;; (assert-equality (ref histogram 1) 1) 365 | ;; (assert-equality (ref histogram 2) 2) 366 | ;; (assert-equality (ref histogram 3) 3) 367 | ;; (assert-equality (ref histogram 7) 0) 368 | ;; ;; (assert-equality (total-frequency histogram) 6) 369 | ;; ;; (assert-equality (relative-frequency histogram 1) 1/6) 370 | ;; ;; (assert-equality (relative-frequency histogram 2) 2/6) 371 | ;; ;; (assert-equality (relative-frequency histogram 3) 3/6) 372 | ;; ;; (assert-equality (relative-frequency histogram 7) 0) 373 | ;; (assert-equality (limits histogram) '((1 . 4))))) 374 | --------------------------------------------------------------------------------