├── .gitignore ├── ChangeLog ├── License.BSD ├── README.org ├── bugs.lisp ├── bugs ├── issue-0f9f8352038ac77680178e45cd0f363202c4f633.yaml ├── issue-12fd9ca85bcd2097139b68b6db32fc07a161c71e.yaml ├── issue-1a80d4a83ff4d550de9577e235a3899ca6220aab.yaml ├── issue-38ad886f49fe1d0d74a18de622a5ae87f6e5d2bf.yaml ├── issue-38b55d478d8b252161787cfdab94bfcfd23d2abd.yaml ├── issue-47db4301e544c127c4f768cbbd746d1e38c0e0ce.yaml ├── issue-4854ba9fc22743175d1e7fcab345092134219338.yaml ├── issue-4d95b924a4defd3adf23fe68f35ac2affb57b79d.yaml ├── issue-4f85931aaf75f80a8ee2b4feef14c89f9fb4eee2.yaml ├── issue-58482a54c494886401cab9bc5834f85cb24cf35d.yaml ├── issue-61cd0017c73baa2c40a2173bdddd1264439b97f8.yaml ├── issue-77535aef412f606c49d965f0415efefe94c65518.yaml ├── issue-7fdeaa11ebf3c744dbfe4fcc169c37bca553e110.yaml ├── issue-8c002779b3bf336283d383efce130a165740de64.yaml ├── issue-983139284d603689fd86845d45a21a87d08de3fb.yaml ├── issue-9e870cf7bdb9eb2e41db60497ab15437b5aa78fc.yaml ├── issue-a5da98afa1f93ed8af6ea8716b6207af8205875c.yaml ├── issue-ad5fe7a6b64f5d87c2b8f1f5772082edf0c27461.yaml ├── issue-afa6e5a68b58f1950cbf1937cd5b859493709dd7.yaml ├── issue-da7adb92daeab1430b2df7f41e8a05612f5acad2.yaml ├── issue-db2d3ac777ae6b2be6b282c816976158bbf39822.yaml ├── issue-f50b98b5945e905f5f0726d4606a6ea868e6eb4d.yaml └── project.yaml ├── examples └── README.org ├── lisp-matrix.asd ├── lispMatrixTests.R └── src ├── benchmark └── lisp-vs-c-aref.lisp ├── data-transform.lisp ├── examples └── bit-vectors.lisp ├── experimental ├── array-backend.lisp ├── element-access.lisp ├── features.lisp ├── fixed-types.lisp ├── gc.lisp ├── index-list-matview.lisp ├── mangle.lisp ├── matview.lisp ├── multiplication.lisp ├── templates.lisp ├── types.lisp ├── utilities.lisp └── vector-as-separate-type.lisp ├── fortran ├── Makefile ├── fortran-mangling.lisp └── shared.c ├── lapack-cholesky.lisp ├── lapack-ls.lisp ├── lapack-lu.lisp ├── lapack-methods.lisp ├── lapack-qr.lisp ├── lapack-svd.lisp ├── lapack-utils.lisp ├── macros.lisp ├── matrix-foreign-array.lisp ├── matrix-implementations.lisp ├── matrix-lisp-array.lisp ├── matrix-operations.lisp ├── matrix.lisp ├── numerical-linear-algebra.lisp ├── old ├── fnv-matrix.lisp └── fnv-vector.lisp ├── package.lisp ├── unittests ├── test-lift.lisp ├── test.lisp ├── unittests-matrix-lapack.lisp ├── unittests-matrix-view.lisp ├── unittests-matrix.lisp ├── unittests-transform.lisp ├── unittests-vector.lisp └── unittests.lisp ├── utils.lisp ├── vector.lisp └── xarray-lispmatrix.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | /.clbuild-skip-update 2 | *.so 3 | *~ 4 | *.fasl 5 | run-emacs.sh 6 | test-results/ 7 | .ditz-config 8 | html/* 9 | -------------------------------------------------------------------------------- /License.BSD: -------------------------------------------------------------------------------- 1 | Lisp-Matrix is a package for experimenting with LAPACK oriented 2 | numerical linear algebra computations. 3 | 4 | Copyright (c) 2005--2007 Mark Hoemmen 5 | 2006-- AJ Rossini 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /bugs.lisp: -------------------------------------------------------------------------------- 1 | ` 2 | (in-package :lisp-matrix-user) 3 | 4 | (M* (ones 2 2 :implementation :foreign-array) 5 | (ones 2 2 :implementation :foreign-array)) 6 | 7 | (element-type (ones 2 2 :implementation :foreign-array)) 8 | ;; problem: it calls GEMM with FA-, FA-, and LA-.... 9 | #| 10 | There is no applicable method for the generic function 11 | # 12 | when called with arguments 13 | (1.0d0 14 | # 17 | # 20 | 0.0d0 21 | #). 24 | [Condition of type SIMPLE-ERROR] 25 | |# 26 | 27 | 28 | (M* (ones 2 2 :implementation :lisp-array) 29 | (ones 2 2 :implementation :lisp-array)) 30 | ;; works 31 | 32 | (M* (ones 2 2 :implementation :lisp-array) 33 | (ones 2 2 :implementation :foriegn-array)) 34 | #| 35 | There is no applicable method for the generic function 36 | # 37 | when called with arguments 38 | (2 2 :FORIEGN-ARRAY :ELEMENT-TYPE DOUBLE-FLOAT 39 | :INITIAL-ELEMENT 1.0d0). 40 | [Condition of type SIMPLE-ERROR] 41 | |# 42 | -------------------------------------------------------------------------------- /bugs/issue-0f9f8352038ac77680178e45cd0f363202c4f633.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: Understand and document copy-back-p 3 | desc: in the with-copies macro in lapack-*, I don't understand how copy-back-p flag is implemented? 4 | type: :task 5 | component: blapack 6 | release: "1.0" 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2009-02-21 10:47:29.871796 Z 11 | references: [] 12 | 13 | id: 0f9f8352038ac77680178e45cd0f363202c4f633 14 | log_events: 15 | - - 2009-02-21 10:47:31.474629 Z 16 | - Tony 17 | - created 18 | - "" 19 | -------------------------------------------------------------------------------- /bugs/issue-12fd9ca85bcd2097139b68b6db32fc07a161c71e.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: Check need for calling twice in call-with-work in lapack-method.lisp 3 | desc: The call happens twice, but this doesn't seem useful? 2x the work? Need to resolve and document. 4 | type: :task 5 | component: blapack 6 | release: "1.0" 7 | reporter: Tony 8 | status: :closed 9 | disposition: :fixed 10 | creation_time: 2009-01-23 07:07:52.122627 Z 11 | references: [] 12 | 13 | id: 12fd9ca85bcd2097139b68b6db32fc07a161c71e 14 | log_events: 15 | - - 2009-01-23 07:07:53.593753 Z 16 | - Tony 17 | - created 18 | - "" 19 | - - 2009-03-13 17:33:47.763811 Z 20 | - Tony 21 | - closed with disposition fixed 22 | - need the 2 calls, first computes lwork, second does the work. 23 | -------------------------------------------------------------------------------- /bugs/issue-1a80d4a83ff4d550de9577e235a3899ca6220aab.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: unittests for row/col-offset access 3 | desc: need unittests to ensure sstem integrity for col/row-offset access 4 | type: :task 5 | component: matrix 6 | release: "1.0" 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2008-12-09 07:30:16.264656 Z 11 | references: [] 12 | 13 | id: 1a80d4a83ff4d550de9577e235a3899ca6220aab 14 | log_events: 15 | - - 2008-12-09 07:30:27.449528 Z 16 | - Tony 17 | - created 18 | - necessary unittest! 19 | - - 2008-12-09 20:37:20.876261 Z 20 | - Tony 21 | - assigned to release 1.0 from unassigned 22 | - "" 23 | -------------------------------------------------------------------------------- /bugs/issue-38ad886f49fe1d0d74a18de622a5ae87f6e5d2bf.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: "Matrix Decomposition method: incremental QR decom, AS274 (Applied stats)" 3 | desc: suggestion from Thomas 4 | type: :feature 5 | component: statnumeric 6 | release: 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2009-03-08 11:54:35.029407 Z 11 | references: [] 12 | 13 | id: 38ad886f49fe1d0d74a18de622a5ae87f6e5d2bf 14 | log_events: 15 | - - 2009-03-08 11:54:42.057281 Z 16 | - Tony 17 | - created 18 | - postponed for a bit. 19 | -------------------------------------------------------------------------------- /bugs/issue-38b55d478d8b252161787cfdab94bfcfd23d2abd.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: SVD decomp and inversion and solution to write 3 | desc: interface to LAPACK SVD functions 4 | type: :feature 5 | component: blapack 6 | release: "1.0" 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2009-03-13 17:36:28.893682 Z 11 | references: [] 12 | 13 | id: 38b55d478d8b252161787cfdab94bfcfd23d2abd 14 | log_events: 15 | - - 2009-03-13 17:36:49.460784 Z 16 | - Tony 17 | - created 18 | - to do so we can compare all factorizsation methods unlike R 19 | -------------------------------------------------------------------------------- /bugs/issue-47db4301e544c127c4f768cbbd746d1e38c0e0ce.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: LICENSE needed, chase down permission from previous authors 3 | desc: |- 4 | release will require a bit of work to ensure that we actually get things done 5 | /stp 6 | type: :task 7 | component: lisp-matrix.git 8 | release: "1.0" 9 | reporter: Tony 10 | status: :unstarted 11 | disposition: 12 | creation_time: 2009-01-23 11:18:28.723367 Z 13 | references: [] 14 | 15 | id: 47db4301e544c127c4f768cbbd746d1e38c0e0ce 16 | log_events: 17 | - - 2009-01-23 11:18:36.468609 Z 18 | - Tony 19 | - created 20 | - will work on it soon. 21 | -------------------------------------------------------------------------------- /bugs/issue-4854ba9fc22743175d1e7fcab345092134219338.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: v+ generics to write 3 | desc: "" 4 | type: :feature 5 | component: vector 6 | release: "1.0" 7 | reporter: Tony 8 | status: :closed 9 | disposition: :fixed 10 | creation_time: 2008-12-15 13:51:54.942316 Z 11 | references: [] 12 | 13 | id: 4854ba9fc22743175d1e7fcab345092134219338 14 | log_events: 15 | - - 2008-12-15 13:51:56.768503 Z 16 | - Tony 17 | - created 18 | - "" 19 | - - 2008-12-16 07:08:58.092993 Z 20 | - Tony 21 | - changed status from unstarted to in_progress 22 | - implement for vector-likes, need to implement for lists and vectors to allow for data transformation 23 | - - 2008-12-16 07:31:24.393363 Z 24 | - Tony 25 | - closed with disposition fixed 26 | - solved for vector-like, still need data-transform 27 | -------------------------------------------------------------------------------- /bugs/issue-4d95b924a4defd3adf23fe68f35ac2affb57b79d.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: integrate the xarray API 3 | desc: need to use/leverage the common xarray API (tamas papp's 2nd gen array access tool). 4 | type: :feature 5 | component: manip 6 | release: "1.0" 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2009-06-23 06:09:44.938397 Z 11 | references: [] 12 | 13 | id: 4d95b924a4defd3adf23fe68f35ac2affb57b79d 14 | log_events: 15 | - - 2009-06-23 06:10:01.176165 Z 16 | - Tony 17 | - created 18 | - working on it, same time as CLS integration for dataframes. 19 | -------------------------------------------------------------------------------- /bugs/issue-4f85931aaf75f80a8ee2b4feef14c89f9fb4eee2.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: FA implementation doesn't support integer matrices 3 | desc: "There is an implementation gap: no support for integer valued foreign arrays." 4 | type: :feature 5 | component: matrix 6 | release: 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2008-12-11 07:04:02.652487 Z 11 | references: [] 12 | 13 | id: 4f85931aaf75f80a8ee2b4feef14c89f9fb4eee2 14 | log_events: 15 | - - 2008-12-11 07:04:26.971582 Z 16 | - Tony 17 | - created 18 | - low priority, since the lisp-array implementation supports it. 19 | -------------------------------------------------------------------------------- /bugs/issue-58482a54c494886401cab9bc5834f85cb24cf35d.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: make-predicate does variable capture and shouldn't 3 | desc: make-predicate works within-package, but not in a user-package due to var capture. 4 | type: :bugfix 5 | component: lisp-matrix.git 6 | release: 7 | reporter: Tony 8 | status: :closed 9 | disposition: :fixed 10 | creation_time: 2008-12-09 07:32:47.465374 Z 11 | references: [] 12 | 13 | id: 58482a54c494886401cab9bc5834f85cb24cf35d 14 | log_events: 15 | - - 2008-12-09 07:33:05.057228 Z 16 | - Tony 17 | - created 18 | - used for fast generic construction of predicates. 19 | - - 2009-02-09 07:36:42.647768 Z 20 | - Tony 21 | - commented 22 | - |- 23 | Might not be solvable -- see current version of TODO and information surrounding 24 | the make-predicate-macro version for why we might not be able to escape capturing A, and 25 | perhaps more importantly, I think it just does not matter. 26 | - - 2009-02-09 07:37:17.220480 Z 27 | - Tony 28 | - closed with disposition fixed 29 | - It is understood, and that is the general fix. 30 | -------------------------------------------------------------------------------- /bugs/issue-61cd0017c73baa2c40a2173bdddd1264439b97f8.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: copy! for vectors barfs 3 | desc: |- 4 | copy! code for vectors is breaking some of the assignments due to inheritance. Need to 5 | robustify it when it gets put back in. 6 | type: :task 7 | component: vector 8 | release: "1.0" 9 | reporter: Tony 10 | status: :paused 11 | disposition: 12 | creation_time: 2008-12-08 19:41:41.410853 Z 13 | references: [] 14 | 15 | id: 61cd0017c73baa2c40a2173bdddd1264439b97f8 16 | log_events: 17 | - - 2008-12-08 19:42:14.346763 Z 18 | - Tony 19 | - created 20 | - this code switches between vector, list, and vector-like. 21 | - - 2008-12-09 20:34:59.828023 Z 22 | - Tony 23 | - changed status from unstarted to in_progress 24 | - |- 25 | some deep confusion with respect to matrices. Perhaps we just leave the matrices as is, 26 | and not worry about the subclass copy? 27 | - - 2008-12-09 20:36:58.222710 Z 28 | - Tony 29 | - assigned to release 1.0 from unassigned 30 | - "" 31 | - - 2008-12-16 07:34:19.863030 Z 32 | - Tony 33 | - changed status from in_progress to paused 34 | - still can't quite figure this out. 35 | -------------------------------------------------------------------------------- /bugs/issue-77535aef412f606c49d965f0415efefe94c65518.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: API for vectorized computations needed 3 | desc: |- 4 | Need to be clear on what we will enable or not enable for vectorization. The 5 | old LispStat approach is not scalable as observed by work done on R since. 6 | type: :task 7 | component: lisp-matrix.git 8 | release: "1.0" 9 | reporter: Tony 10 | status: :in_progress 11 | disposition: 12 | creation_time: 2008-12-15 07:17:30.655527 Z 13 | references: [] 14 | 15 | id: 77535aef412f606c49d965f0415efefe94c65518 16 | log_events: 17 | - - 2008-12-15 07:17:45.437980 Z 18 | - Tony 19 | - created 20 | - see TODO.lisp for the current thinking. 21 | - - 2008-12-16 07:35:23.382627 Z 22 | - Tony 23 | - changed status from unstarted to in_progress 24 | - |- 25 | recent commits have done some of this. Current open issue is whether to use generics for auto-transform, 26 | or make conversion an explicit activity. both have merits. 27 | -------------------------------------------------------------------------------- /bugs/issue-7fdeaa11ebf3c744dbfe4fcc169c37bca553e110.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: lisp data to lisp-matrix data, and vice-versa. 3 | desc: |- 4 | need an API to convert "obvious" lisp data formats (list of lists and arrays to matrix-likes, 5 | lists and vectors to vector-likes. 6 | type: :feature 7 | component: manip 8 | release: "1.0" 9 | reporter: Tony 10 | status: :unstarted 11 | disposition: 12 | creation_time: 2009-01-03 19:02:07.197623 Z 13 | references: [] 14 | 15 | id: 7fdeaa11ebf3c744dbfe4fcc169c37bca553e110 16 | log_events: 17 | - - 2009-01-03 19:02:16.863745 Z 18 | - Tony 19 | - created 20 | - working on it slowly. 21 | -------------------------------------------------------------------------------- /bugs/issue-8c002779b3bf336283d383efce130a165740de64.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: Need to add tools for triangular (trapazoidal) matrices. 3 | desc: special triangular structures are used in LAPACK/BLAS, need to be able to leverage. 4 | type: :feature 5 | component: matrix 6 | release: 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2009-02-05 12:23:04.394995 Z 11 | references: [] 12 | 13 | id: 8c002779b3bf336283d383efce130a165740de64 14 | log_events: 15 | - - 2009-02-05 12:23:06.361288 Z 16 | - Tony 17 | - created 18 | - "" 19 | -------------------------------------------------------------------------------- /bugs/issue-983139284d603689fd86845d45a21a87d08de3fb.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: M* doesn't work for foreign arrays 3 | desc: failure to recognize class for m* through the gemm pass-through. 4 | type: :bugfix 5 | component: matrix 6 | release: 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2008-12-17 07:28:52.709537 Z 11 | references: [] 12 | 13 | id: 983139284d603689fd86845d45a21a87d08de3fb 14 | log_events: 15 | - - 2008-12-17 07:29:17.188037 Z 16 | - Tony 17 | - created 18 | - not sure if it is an m* or gemm/cl-blapack problem. 19 | - - 2008-12-17 07:30:26.202691 Z 20 | - Tony 21 | - commented 22 | - do we need to fix def-lapack-method? 23 | - - 2008-12-18 06:13:02.649831 Z 24 | - Tony 25 | - edited title 26 | - issue is with foreign arrays, not classes in general. 27 | -------------------------------------------------------------------------------- /bugs/issue-9e870cf7bdb9eb2e41db60497ab15437b5aa78fc.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: v* / v/ generics to write 3 | desc: mult and divide generics are different than normal. 4 | type: :task 5 | component: vector 6 | release: "1.0" 7 | reporter: Tony 8 | status: :closed 9 | disposition: :fixed 10 | creation_time: 2008-12-15 13:54:31.256057 Z 11 | references: [] 12 | 13 | id: 9e870cf7bdb9eb2e41db60497ab15437b5aa78fc 14 | log_events: 15 | - - 2008-12-15 13:54:32.697167 Z 16 | - Tony 17 | - created 18 | - "" 19 | - - 2008-12-16 07:09:43.349147 Z 20 | - Tony 21 | - changed status from unstarted to in_progress 22 | - unlike v+/v-, need to consider semantics with respect to m* and m/ 23 | - - 2008-12-16 07:32:13.930057 Z 24 | - Tony 25 | - closed with disposition fixed 26 | - solved for vector-like 27 | -------------------------------------------------------------------------------- /bugs/issue-a5da98afa1f93ed8af6ea8716b6207af8205875c.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: docs for extend data manipulation (bind, r-like-apply) 3 | desc: Need to write up and incorporate docs for data manipulation of matrices. 4 | type: :feature 5 | component: docs 6 | release: "1.0" 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2008-12-10 07:33:07.590621 Z 11 | references: [] 12 | 13 | id: a5da98afa1f93ed8af6ea8716b6207af8205875c 14 | log_events: 15 | - - 2008-12-10 07:33:10.792518 Z 16 | - Tony 17 | - created 18 | - "" 19 | -------------------------------------------------------------------------------- /bugs/issue-ad5fe7a6b64f5d87c2b8f1f5772082edf0c27461.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: m./ generic needs test cases 3 | desc: need to implement and write test cases for m./ 4 | type: :task 5 | component: matrix 6 | release: "1.0" 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2009-02-06 10:14:43.642727 Z 11 | references: [] 12 | 13 | id: ad5fe7a6b64f5d87c2b8f1f5772082edf0c27461 14 | log_events: 15 | - - 2009-02-06 10:14:46.754491 Z 16 | - Tony 17 | - created 18 | - /stp 19 | -------------------------------------------------------------------------------- /bugs/issue-afa6e5a68b58f1950cbf1937cd5b859493709dd7.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: Need to implement sweep operator 3 | desc: |- 4 | sweep operator needed for conformance with LispStat. Possible strategy 5 | is to skip and use a better least-squares approach for linear regression. 6 | type: :feature 7 | component: statnumeric 8 | release: 9 | reporter: Tony 10 | status: :unstarted 11 | disposition: 12 | creation_time: 2008-12-08 18:06:58.914465 Z 13 | references: [] 14 | 15 | id: afa6e5a68b58f1950cbf1937cd5b859493709dd7 16 | log_events: 17 | - - 2008-12-08 18:07:09.279658 Z 18 | - Tony 19 | - created 20 | - on hold 21 | -------------------------------------------------------------------------------- /bugs/issue-da7adb92daeab1430b2df7f41e8a05612f5acad2.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: Need def-lapack-method to have a doc-string input so to customize the func/meth docs 3 | desc: Must ensure a way to add operation docs to doc-string for clarity 4 | type: :feature 5 | component: blapack 6 | release: "1.0" 7 | reporter: Tony 8 | status: :unstarted 9 | disposition: 10 | creation_time: 2009-03-18 13:54:38.206034 Z 11 | references: [] 12 | 13 | id: da7adb92daeab1430b2df7f41e8a05612f5acad2 14 | log_events: 15 | - - 2009-03-18 13:54:39.513316 Z 16 | - Tony 17 | - created 18 | - "" 19 | -------------------------------------------------------------------------------- /bugs/issue-db2d3ac777ae6b2be6b282c816976158bbf39822.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: unittests for v+,v-,v*,v/ needed 3 | desc: write 'em! 4 | type: :task 5 | component: vector 6 | release: "1.0" 7 | reporter: Tony 8 | status: :closed 9 | disposition: :fixed 10 | creation_time: 2008-12-16 07:10:39.216753 Z 11 | references: [] 12 | 13 | id: db2d3ac777ae6b2be6b282c816976158bbf39822 14 | log_events: 15 | - - 2008-12-16 07:10:41.745953 Z 16 | - Tony 17 | - created 18 | - "" 19 | - - 2008-12-16 07:31:52.908955 Z 20 | - Tony 21 | - closed with disposition fixed 22 | - solved for vector-like, still need data-transform 23 | -------------------------------------------------------------------------------- /bugs/issue-f50b98b5945e905f5f0726d4606a6ea868e6eb4d.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/issue 2 | title: Clean up Linear Models datasets 3 | desc: |- 4 | Currently, we've got linear models work being a bit unclean, need to straighten up via data in 5 | order to take care of clean use. 6 | type: :task 7 | component: lisp-matrix.git 8 | release: "1.0" 9 | reporter: Tony 10 | status: :unstarted 11 | disposition: 12 | creation_time: 2009-01-21 08:14:05.333592 Z 13 | references: [] 14 | 15 | id: f50b98b5945e905f5f0726d4606a6ea868e6eb4d 16 | log_events: 17 | - - 2009-01-21 08:14:27.894062 Z 18 | - Tony 19 | - created 20 | - in progress, but part manip and part to be migrated into CLS 21 | -------------------------------------------------------------------------------- /bugs/project.yaml: -------------------------------------------------------------------------------- 1 | --- !ditz.rubyforge.org,2008-03-06/project 2 | name: lisp-matrix.git 3 | version: "0.5" 4 | components: 5 | - !ditz.rubyforge.org,2008-03-06/component 6 | name: lisp-matrix.git 7 | - !ditz.rubyforge.org,2008-03-06/component 8 | name: matrix 9 | - !ditz.rubyforge.org,2008-03-06/component 10 | name: vector 11 | - !ditz.rubyforge.org,2008-03-06/component 12 | name: blapack 13 | - !ditz.rubyforge.org,2008-03-06/component 14 | name: manip 15 | - !ditz.rubyforge.org,2008-03-06/component 16 | name: statnumeric 17 | - !ditz.rubyforge.org,2008-03-06/component 18 | name: docs 19 | releases: 20 | - !ditz.rubyforge.org,2008-03-06/release 21 | name: "1.0" 22 | status: :unreleased 23 | release_time: 24 | log_events: 25 | - - 2008-12-09 20:36:33.111061 Z 26 | - Tony 27 | - created 28 | - first version with clean foreign arrays and most BLAS/LAPACK. 29 | - !ditz.rubyforge.org,2008-03-06/release 30 | name: "2.0" 31 | status: :unreleased 32 | release_time: 33 | log_events: 34 | - - 2008-12-15 07:18:23.207747 Z 35 | - Tony 36 | - created 37 | - future planning at this stage. 38 | -------------------------------------------------------------------------------- /examples/README.org: -------------------------------------------------------------------------------- 1 | 2 | * Overview 3 | 4 | This is technically the TODO file, used as a live testing ground as 5 | well. 6 | 7 | * Tasks 8 | 9 | ** TODO [#B] M Maul's request, GEMM for foriegn arrays 10 | DEADLINE: <2013-02-03 Sun> SCHEDULED: <2012-12-21 Fri> 11 | 12 | <2012-12-21 Fri> 13 | 14 | How hard would it be to implement support for foreign-array in M*? 15 | 16 | #+begin_src lisp 17 | (M* (ones 2 2 :implementation :foreign-array) 18 | (ones 2 2 :implementation :foreign-array)) 19 | #+end_src 20 | 21 | results with: 22 | 23 | #+begin_example 24 | There is no applicable method for the generic function: 25 | # 26 | when called with arguments: 27 | (1.0 # 30 | # 33 | 0.0 #) 36 | [Condition of type SIMPLE-ERROR] 37 | #+end_example 38 | 39 | Well in all the M functions for that matter. There is functionality 40 | needed in blas libraries which require foreign-arrays. 41 | 42 | Consequently I am using copy* do to conversions back and forth 43 | between lisp-array and foreign-array which is slows things down 44 | quite a drastically. 45 | 46 | On the plus side when copy's are not necessary performance is not 47 | too bad. In fact it is about 4x faster then interpreted 48 | lush. Compiled lush is 14 times faster, but compiled lush is mostly 49 | syntatic sugar over C and there is tight integration with lush and 50 | it's matrix code which is mostly implemented in C. 51 | 52 | If your interested here is my code I've been using to evaluate 53 | lisp-matrix: 54 | 55 | #+begin_src lisp 56 | ;; (ql:quickload :antik) 57 | ;; (ql:quickload :lisp-matrix) 58 | (in-package :lisp-matrix-user) ; not sure if this is right (Tony) 59 | (defparameter *ex1data2-array* (csv-file->array "ex1data2.txt" )) 60 | (defparameter *ex1data2-array* (make-array '(47 3) :initial-element 12.d0 :adjustable t)) 61 | (defparameter *ex1data2-matrix* 62 | (make-matrix 47 3 63 | :implementation :lisp-array ;:foreign-array 64 | :element-type 'double-float 65 | :initial-contents *ex1data2-array*)) 66 | (defparameter *ex1data1* 67 | (make-matrix 97 3 68 | :implementation :lisp-array ;:foreign-array 69 | :element-type 'double-float 70 | :initial-contents (csv-file->array "ex1data1.txt" :oness 1))) 71 | (defparameter theta (zeros 2 1)) 72 | (defparameter X (strides *ex1data1* :ncols 2)) 73 | (defparameter y (strides *ex1data1* :ncols 1 :col-offset 2)) 74 | (defparameter iterations 1500) 75 | (defparameter alpha 0.01) 76 | (defparameter theta1 77 | (make-matrix 2 1 78 | :implementation :lisp-array ;foreign-array 79 | :Initial-contents '((.2d0) (.2d0)))) 80 | 81 | (defun cost (X y theta) 82 | (let* ((h (M* X theta)) 83 | (h-y (M.- h y)) 84 | (h-y**2 (M.* h-y h-y)) 85 | (m (nrows X))) 86 | (* (/ 1d0 (* 2d0 m)) 87 | (asum h-y**2)))) 88 | 89 | (defun gradient (X y theta alpha) 90 | (let* ((m (nrows X*)) 91 | (alpha*1/m (* alpha (/ 1 m))) 92 | (h (M* X theta)) 93 | (h-y*X (M* (transpose-matrix (M.- h y)) X))) 94 | (M.- theta 95 | (copy* (scal alpha*1/m 96 | (copy* h-y*X :foreign-array)) :lisp-array)))) 97 | 98 | #+end_src 99 | 100 | If you have any suggestions regarding my use of lisp-matrix I'd 101 | love to hear them. 102 | 103 | If you can give some hints for supporting foreign-array in the M 104 | functions I'm not above implementing them. 105 | 106 | In general I do like the interface. As a comparison below is 107 | equivalent code in lush: 108 | 109 | #+begin_src lush 110 | (defun compute-cost-nc (X y theta) 111 | (let* ((m (length X)) 112 | (h (idx-reshape (idx-m2dotm1 X theta) (list m 1))) 113 | ) 114 | ((* (/ 1 (* 2 m)) (mat-sum (** (- h y) 2))) 0) 115 | ) 116 | ) 117 | 118 | (defun gradient-nc (X y theta alpha) 119 | (let* ((m (idx-shape X 0)) 120 | (alpha*1/m (* alpha (/ 1 m))) 121 | (h (idx-reshape (idx-m2dotm1 X theta ) (list m 1))) 122 | (h-y*X (mat-.* (mat-transpose (- h y)) X)) 123 | ) 124 | (idx-flatten (- theta (* h-y*X alpha*1/m))) 125 | ) 126 | ) 127 | #+end_src 128 | 129 | 130 | -------------------------------------------------------------------------------- /lisp-matrix.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | 3 | ;;; TODO: wrap this in a #+(or ) with an error if 4 | ;;; the system isn't supported. 5 | ;;; 6 | (in-package :cl-user) 7 | 8 | (defpackage :lisp-matrix-asd 9 | (:use :cl :asdf)) 10 | 11 | (in-package :lisp-matrix-asd) 12 | 13 | (defsystem lisp-matrix 14 | :name "lisp-matrix" 15 | :version "0.3" 16 | :author "Mark Hoemmen " 17 | :license "BSD sans advertising clause" ;; sort of MIT 18 | :description "linear algebra library" 19 | :long-description "Linear algebra library for ANSI Common Lisp; 20 | implemented at the lowest level using CFFI to call the BLAS and 21 | LAPACK. Should run on any ANSI CL implementation that supports 22 | CFFI. Uses both lisp-centric and foreign-centric storage, in a 23 | manner friendly to the complimentary other storage facility." 24 | :serial t 25 | :depends-on (:cffi 26 | :cl-utilities 27 | :xarray ; we will use this for general indexing 28 | ;; :fiveam ;;see below for its replacement... 29 | :lift ;; yes, Tony (me) is a PITA... 30 | :org.middleangle.foreign-numeric-vector 31 | :org.middleangle.cl-blapack 32 | :ffa) 33 | :components 34 | ((:module 35 | "package-init" 36 | :pathname #p "src/" 37 | :components 38 | ((:file "package"))) 39 | 40 | (:module 41 | "basics" 42 | :pathname #p"src/" 43 | :depends-on ("package-init") 44 | :components 45 | ((:file "utils" ) 46 | (:file "macros" ) 47 | (:file "matrix" ) 48 | (:file "vector" :depends-on ("matrix")) 49 | (:file "data-transform" :depends-on ("matrix" "vector")) 50 | (:file "matrix-implementations" :depends-on ("matrix" "vector")))) 51 | 52 | (:module 53 | "implementations" 54 | :pathname #p"src/" 55 | :depends-on ("package-init" "basics") 56 | :serial t 57 | :components 58 | ((:file "matrix-lisp-array") 59 | (:file "matrix-foreign-array") 60 | ;; probably should move the remainder into a numerical linear 61 | ;; algebra place. 62 | (:file "lapack-utils" :depends-on ("matrix-foreign-array" 63 | "matrix-lisp-array")) 64 | (:file "lapack-methods" :depends-on ("lapack-utils")) 65 | (:file "lapack-cholesky" :depends-on ("lapack-utils")) 66 | (:file "lapack-lu" :depends-on ("lapack-utils")) 67 | (:file "lapack-qr" :depends-on ("lapack-utils")) 68 | (:file "lapack-svd" :depends-on ("lapack-utils")) 69 | 70 | (:file "lapack-ls" :depends-on ("lapack-utils")) 71 | 72 | (:file "matrix-operations" :depends-on ("lapack-methods" 73 | "lapack-cholesky" 74 | "lapack-lu" 75 | "lapack-qr")))) 76 | (:module 77 | "api" 78 | :pathname #p"src/" 79 | :depends-on ("basics" "implementations") 80 | :components 81 | ((:file "numerical-linear-algebra"))) 82 | 83 | (:module 84 | "testing" 85 | :pathname #p "src/unittests/" 86 | :depends-on ("implementations") 87 | :components 88 | ((:file "unittests") 89 | (:file "unittests-transform" :depends-on ("unittests")) 90 | (:file "unittests-matrix" :depends-on ("unittests")) 91 | (:file "unittests-matrix-view" :depends-on ("unittests" "unittests-matrix")) 92 | (:file "unittests-matrix-lapack" :depends-on ("unittests" "unittests-matrix")) 93 | (:file "unittests-vector" :depends-on ("unittests"))))) 94 | 95 | #| 96 | :in-order-to ((test-op (load-op lisp-matrix))) 97 | :perform (test-op :after (op c) 98 | (funcall (intern "RUN!" 'fiveam) 99 | (intern "TESTS" 'lisp-matrix))) 100 | |# 101 | ) 102 | -------------------------------------------------------------------------------- /lispMatrixTests.R: -------------------------------------------------------------------------------- 1 | 2 | ## From TODO: 3 | 4 | m01 <- matrix(data=c(11.0, 12.0, 13.0, 14.0, 15.0, 5 | 21.0, 22.0, 23.0, 24.0, 25.0, 6 | 31.0, 32.0, 33.0, 34.0, 35.0, 7 | 41.0, 42.0, 43.0, 44.0, 45.0, 8 | 51.0, 52.0, 53.0, 54.0, 55.0, 9 | 61.0, 62.0, 63.0, 64.0, 65.0), 10 | nrow=6, ncol=5,byrow=TRUE) 11 | 12 | m01 13 | mtm <- t(m01) %*% m01 14 | mtm 15 | 16 | qr(mtm) 17 | 18 | solve(mtm) 19 | 20 | -------------------------------------------------------------------------------- /src/benchmark/lisp-vs-c-aref.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | 4 | (defpackage :matrix-benchmarks 5 | (:use :cl 6 | :cffi 7 | :lisp-matrix 8 | :matlisp) 9 | (:export :run-benchmark :run-benchmarks)) 10 | 11 | 12 | (in-package :matrix-benchmarks) 13 | 14 | ;;; Pull out all the optimization stops. 15 | (declaim (optimize (safety 0) (debug 0) (speed 3))) 16 | 17 | ;;; Make sure you've loaded ASDF and your CFFI directory was pushed 18 | ;;; onto asdf:*central-registry*. 19 | (asdf:oos 'asdf:load-op :cffi) 20 | 21 | ;;; We set the array size to 4 million so that the benchmark takes a 22 | ;;; decent amount of time to run and so that the array doesn't fit in 23 | ;;; cache (MAKE-ARRAY with the :INITIAL-ELEMENT keyword causes the 24 | ;;; array to be written to, meaning that the whole array could be in 25 | ;;; the cache). Of course if you have an IBM Power5 with its monster 26 | ;;; 36 MB L3 cache, you might want to change this value :P 27 | (defconstant +ASIZE+ 4000000) 28 | (declaim (type fixnum +ASIZE+)) 29 | 30 | 31 | (defmacro fill-foreign-array (array-name type count with-what) 32 | "Fills the given foreign array ARRAY-NAME with COUNT elements 33 | WITH-WHAT, each of which are of (CFFI) type TYPE. Macro- 34 | expansion fails if the macro doesn't recognize the given type." 35 | (cond ((or (eq type :double) (eq type 'double)) 36 | `(dotimes (i ,count) 37 | (declare (type fixnum i ,count)) 38 | (setf (cffi:mem-aref ,array-name :double i) 39 | (the double-float ,with-what)))) 40 | ((or (eq type :int) (eq type 'int)) 41 | `(dotimes (i ,count) 42 | (declare (type fixnum i ,count)) 43 | (setf (cffi:mem-aref ,array-name :int i) 44 | ,with-what))) 45 | (t (error "I don't know how to fill with type ~A" type)))) 46 | 47 | ;;; Here is a more general FILL-FOREIGN-ARRAY. Note that it doesn't 48 | ;;; do any type checking on ARRAY-NAME. 49 | #| 50 | (defmacro fill-foreign-array (array-name type count with-what) 51 | `(dotimes (i ,count) 52 | (declare (type fixnum i ,count)) 53 | (setf (cffi:mem-aref ,array-name ,type i) ,with-what))) 54 | |# 55 | 56 | (defmacro with-foreign-alloc ((array-name 57 | type count 58 | &optional (init-elt 0 init-elt-supplied-p)) 59 | &body body) 60 | "Allocates a foreign array (on the heap) named ARRAY-NAME of 61 | CFFI type TYPE containing COUNT elements. If INIT-ELT is 62 | supplied, all the elements of ARRAY-NAME are set to INIT-ELT. 63 | Then BODY is executed in an UNWIND-PROTECT, and the foreign 64 | array is deallocated." 65 | (if init-elt-supplied-p 66 | `(let ((,array-name (cffi:foreign-alloc ,type :count ,count))) 67 | (fill-foreign-array ,array-name ,type ,count ,init-elt) 68 | (unwind-protect 69 | (progn 70 | ,@body) 71 | (cffi:foreign-free ,array-name))) 72 | `(let ((,array-name (cffi:foreign-alloc ,type :count ,count)) 73 | (unwind-protect 74 | (progn 75 | ,@body) 76 | (cffi:foreign-free ,array-name)))))) 77 | 78 | 79 | 80 | (defun lisp-aref-benchmark () 81 | "Benchmark for a 1-D Lisp array, with AREF." 82 | (let ((A (make-array +ASIZE+ 83 | :element-type 'double-float 84 | :initial-element 1.0d0)) 85 | (s 0.0d0)) 86 | (declare (type double-float s)) 87 | (declare (type (simple-array double-float (*)) A)) 88 | (dotimes (i +ASIZE+ s) 89 | (declare (type fixnum i)) 90 | (incf s (aref A i))))) 91 | 92 | 93 | 94 | (defun foreign-aref-benchmark () 95 | "Benchmark for a 1-D C array, with CFFI:MEM-AREF. The function does pointer 96 | arithmetic every time it is called." 97 | (with-foreign-alloc (A :double +ASIZE+ 1.0d0) 98 | (let ((s 0.0d0)) 99 | (declare (type double-float s)) 100 | (dotimes (i +ASIZE+ s) 101 | (declare (type fixnum i)) 102 | (incf s (cffi:mem-aref A :double i)))))) 103 | 104 | 105 | (defun optimized-foreign-aref-benchmark () 106 | "Benchmark for a 1-D C array, with CFFI:MEM-REF instead of CFFI:MEM-AREF. 107 | We do the pointer arithmetic by hand. CFFI makes this awkward since a 108 | pointer may be an object different than an (unsigned-byte 32); you have 109 | to call INC-POINTER instead of just adding 8 to it. Thus, the word 110 | \"optimized\" in the name of this function should be taken with a grain 111 | of salt." 112 | (with-foreign-alloc (A :double +ASIZE+ 1.0d0) 113 | (let ((s 0.0d0)) 114 | (declare (type double-float s)) 115 | ;; We need to make sure that B is a deep copy of A. 116 | ;; We'll be playing with B's address but we need to 117 | ;; hold on to A so that WITH-FOREIGN-ALLOC will 118 | ;; deallocate the array correctly. 119 | (let ((B (cffi:make-pointer (cffi:pointer-address A)))) 120 | (dotimes (i +ASIZE+ s) 121 | (declare (type fixnum i)) 122 | (incf s (cffi:mem-ref B :double)) 123 | ;; inc-pointer might cons (it returns a new pointer). 124 | (setf B (cffi:inc-pointer B 8))))))) 125 | 126 | ;;; lisp-matrix benchmark 127 | 128 | (defun lisp-matrix-vref-benchmark () 129 | (let ((a (make-vector +asize+ 'lisp-matrix::double :initial-element 1d0)) 130 | (s 0d0)) 131 | (declare (type double-float s) 132 | (type vector-double a)) 133 | (dotimes (i +ASIZE+ s) 134 | (declare (type fixnum i)) 135 | (incf s (vref a i))))) 136 | 137 | ;;; matlisp benchmarks 138 | 139 | (defun matlisp-mref-benchmark () 140 | (let ((a (matlisp::ones +ASIZE+ 1)) 141 | (s 0d0)) 142 | (declare (type double-float s) 143 | (type matlisp::real-matrix a)) 144 | (dotimes (i +ASIZE+ s) 145 | (declare (type fixnum i)) 146 | (incf s (matlisp::mref a i))))) 147 | 148 | (defun matlisp-store-aref-benchmark () 149 | (let* ((a (matlisp:ones +ASIZE+ 1)) 150 | (s 0d0) 151 | (st (matlisp::store a))) 152 | (declare (type double-float s) 153 | (type matlisp::real-matrix a) 154 | (type (simple-array double-float (*)) st)) 155 | (dotimes (i +ASIZE+ s) 156 | (declare (type fixnum i)) 157 | (incf s (aref st i))))) 158 | -------------------------------------------------------------------------------- /src/data-transform.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp -*- 2 | 3 | ;;; Time-stamp: <2012-11-29 13:33:26 tony> 4 | ;;; Creation: <2008-12-02 17:28:08 tony> 5 | ;;; File: data-transform.lisp 6 | ;;; Author: AJ Rossini 7 | ;;; Copyright: (c)2008--, AJ Rossini. 8 | ;;; License: MIT 9 | ;;; Purpose: conversion functions: 10 | ;;; + lists <-> vector-like 11 | ;;; lists of lists <-> matrix-like 12 | ;;; vector <-> vector-like 13 | ;;; array <-> vector-like 14 | ;;; array <-> matrix-like 15 | 16 | ;;; What is this talk of 'release'? Klingons do not make software 17 | ;;; 'releases'. Our software 'escapes', leaving a bloody trail of 18 | ;;; designers and quality assurance people in its wake. 19 | 20 | ;;; Somewhere, we need to include some helper functions which allow us 21 | ;;; to convert between lists and vectors, and between lists of lists 22 | ;;; and matrices. This is the only point of this file's functions. 23 | 24 | ;;; While any sensible lisp programmer would savor the API, I´m 25 | ;;; corrupting it in favor of getting-stuff-done. 26 | 27 | (in-package :lisp-matrix) 28 | 29 | ;;; LIST <-> VECTOR-LIKE 30 | 31 | (defun list->vector-like (listvar 32 | &key 33 | (coerce-to 'double-float) 34 | (orientation :row)) 35 | "Create a vector-like using default implementation. Use globals to 36 | change implementation, etc. By default, we assume lists are 37 | variables, not cases (i.e. follow lispstat convention), and therefore 38 | convert to column." 39 | (make-vector (length listvar) 40 | :type orientation 41 | :initial-contents 42 | (ecase orientation 43 | (:row 44 | (list 45 | (mapcar #'(lambda (x) (coerce x coerce-to)) 46 | listvar))) 47 | (:column 48 | (mapcar #'(lambda (x) (list (coerce x coerce-to))) 49 | listvar))))) 50 | 51 | (defun vector-like->list (vecvar) 52 | "Create a list from a vector-like." 53 | (let ((result (make-array (list (nelts vecvar))))) 54 | (dotimes (i (nelts vecvar)) 55 | (setf (aref result i) (vref vecvar i))) 56 | result)) 57 | 58 | 59 | ;; FIXME: this function needs to be: 60 | ;; - improved (efficiency/speed) 61 | ;; - made generic possibly with a different name/API, to support 62 | ;; sparse trapezoid and triangular matrices, and other similar 63 | ;; types. 64 | ;; - possible: learn to use classes to determine TYPE. 65 | (defun trap2mat (m &key (type :upper)) 66 | "Copy the trapezoid, lower or upper, into the other side (i.e. upper 67 | triagular storage into full storage). For non-square matrices, there 68 | might be a bit of excess to ignore; but we only handle the top square 69 | of the rectangle." 70 | (check-type m matrix-like) 71 | (let ((mindim (reduce #'min (matrix-dimensions m))) 72 | (result (copy m))) 73 | (ecase type 74 | (:upper (dotimes (i mindim) 75 | (dotimes (j i) 76 | (setf (mref result i j) (mref m j i))))) 77 | (:lower (dotimes (i mindim) 78 | (dotimes (j i) 79 | (setf (mref result j i) (mref m i j)))))) 80 | result)) 81 | 82 | #| 83 | (defparameter *trap2mat-test1* 84 | (make-matrix 3 3 :initial-contents '((1d0 2d0 3d0) (4d0 5d0 6d0) (7d0 8d0 9d0)))) 85 | (assert (matrix-like-symmetric-p (trap2mat *trap2mat-test1*))) 86 | (assert (matrix-like-symmetric-p (trap2mat *trap2mat-test1* :type :upper))) 87 | (assert (matrix-like-symmetric-p (trap2mat *trap2mat-test1* :type :lower))) 88 | |# 89 | -------------------------------------------------------------------------------- /src/examples/bit-vectors.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Author: mfh 2 | ;;;; Date: 1 Jan 2007 3 | ;;;; Last modified: 1 Jan 2007 4 | ;;;; 5 | ;;;; Fun with bit vectors! 6 | 7 | ;;; Functions for working with 'em. 8 | 9 | (in-package :lisp-matrix) 10 | 11 | (defun bvinc! (bv) 12 | "an in-place cascade bit incrementer, assuming that the least 13 | signficant bit is (bit bv 0)." 14 | (let ((L (array-dimension bv 0))) 15 | (cond ((= L 0) 16 | bv) 17 | (t 18 | (loop with c = 1 for i from 0 upto (1- L) do 19 | (psetf (bit bv i) (logxor (bit bv i) c) 20 | c (logand (bit bv i) c)) 21 | finally (return bv)))))) 22 | 23 | 24 | (defun bvinc1! (bv) 25 | "same as above, but (bit bv 0) is the most significant bit." 26 | (let ((L (array-dimension bv 0))) 27 | (cond ((= L 0) 28 | bv) 29 | (t 30 | (loop with c = 1 for i from (1- L) downto 0 do 31 | (psetf (bit bv i) (logxor (bit bv i) c) 32 | c (logand (bit bv i) c)) 33 | finally (return bv)))))) 34 | 35 | 36 | (defun bv2int (bv) 37 | "converts the given bit vector to an integer, assuming that the 38 | least significant bit is (bit bv 0)." 39 | (let ((L (array-dimension bv 0))) 40 | (cond ((= L 0) 0) 41 | (t 42 | (loop with x = 0 43 | with p = 1 44 | for i from 0 upto (1- L) do 45 | (incf x (* (bit bv i) p)) 46 | (setf p (* 2 p)) 47 | finally (return x)))))) 48 | 49 | (defun bv2int1 (bv) 50 | "same as above except (bit bv 0) is msb." 51 | (let ((L (array-dimension bv 0))) 52 | (cond ((= L 0) 0) 53 | (t 54 | (loop with x = 0 55 | with p = 1 56 | for i from (1- L) downto 0 do 57 | (incf x (* (bit bv i) p)) 58 | (setf p (* 2 p)) 59 | finally (return x)))))) 60 | -------------------------------------------------------------------------------- /src/experimental/array-backend.lisp: -------------------------------------------------------------------------------- 1 | ;;;; array-backend.lisp 2 | ;;;; Author: mfh 3 | ;;;; Created: 15 Oct 2006 4 | ;;;; Last modified: 21 Oct 2006 5 | ;;;; 6 | ;;;; Macros that hide how vectors and matrices are stored in memory. 7 | ;;;; Needs: CFFI features.lisp types.lisp 8 | ;;;; 9 | 10 | (defpackage :array-backend 11 | (:use :common-lisp :types) 12 | (:export :fill-foreign-array 13 | :ll-aref 14 | :ll-make-array 15 | :ll-displaced-array)) 16 | (in-package :array-backend) 17 | 18 | 19 | ;;; FIXME: Type declaration might be too general in the case that 20 | ;;; TYPE is not a constant at macro-expansion time. If it is a 21 | ;;; constant, we get a nice declaration. NOTE: LISP-ARRAY MUST 22 | ;;; be a SIMPLE-ARRAY, otherwise you're in trouble!!! 23 | ;;; 24 | (defmacro copy-into-foreign (foreign-array lisp-array type count) 25 | (let ((index (gensym)) 26 | (type-decl (if (constantp type) 27 | `(declare (type ,lisp-array (simple-array ,(cffitype->lisp type) (*)))) 28 | `(declare (type ,lisp-array (simple-array * (*)))))) 29 | (the-type (gensym))) 30 | (if (constantp type) 31 | `(dotimes (,index ,count ,foreign-array) 32 | ,type-decl 33 | (setf (cffi:mem-aref ,foreign-array ,(lisptype->cffi type) ,index) 34 | (aref ,lisp-array ,index))) 35 | `(let ((,the-type (cffitype->lisp ,type))) 36 | (dotimes (,index ,count ,foreign-array)) 37 | ,type-decl 38 | (setf (cffi:mem-aref ,foreign-array ,the-type ,index) 39 | (aref ,lisp-array ,index)))))) 40 | 41 | (defmacro copy-into-lisp (lisp-array foreign-array type count) 42 | (let ((index (gensym)) 43 | (type-decl (if (constantp type) 44 | `(declare (type ,lisp-array (simple-array ,(cffitype->lisp type) (*)))) 45 | `(declare (type ,lisp-array (simple-array * (*)))))) 46 | (the-type (gensym))) 47 | (if (constantp type) 48 | `(dotimes (,index ,count ,lisp-array) 49 | ,type-decl 50 | (setf (aref ,lisp-array ,index) 51 | (cffi:mem-aref ,foreign-array ,(lisptype->cffi type) ,index))) 52 | `(let ((,the-type (cffitype->lisp ,type))) 53 | (dotimes (,index ,count ,lisp-array)) 54 | ,type-decl 55 | (setf (aref ,lisp-array ,index) 56 | (cffi:mem-aref ,foreign-array ,the-type ,index)))))) 57 | 58 | 59 | 60 | 61 | (defmacro fill-foreign-array (array-name type count with-what) 62 | "Fills the given foreign array ARRAY-NAME with COUNT elements 63 | WITH-WHAT." 64 | (let ((fill-with (gensym)) 65 | (index (gensym)) 66 | (cffi-type-expr (if (constantp type) 67 | (lisptype->cffi type) 68 | `(lisptype->cffi ,type))) 69 | (lisp-type-expr (if (constantp type) 70 | (cffitype->lisp type) 71 | `(cffitype->lisp ,type))) 72 | (coerce-expr (if (and (constantp type) (constantp with-what)) 73 | (coerce with-what (cffitype->lisp type)) 74 | `(coerce ,with-what (cffitype->lisp ,type))))) 75 | `(let ((,fill-with ,coerce-expr)) 76 | (dotimes (,index ,count ,array-name) 77 | (declare (type fixnum ,index ,count)) 78 | (setf (cffi:mem-aref ,array-name ,cffi-type-expr ,index) ,fill-with))))) 79 | 80 | (defmacro ll-aref (array-name type index) 81 | "AREF for blocks of memory (see the GSL documentation for a 82 | good definition of \"block\"), however those blocks may be 83 | implemented. You have to give the element type. \"ll\" 84 | stands for \"low-level\"." 85 | (let ((cffi-type-expr (if (constantp type) (lisptype->cffi type) 86 | `(lisptype->cffi ,type))) 87 | (lisp-type-expr (if (constantp type) (cffitype->lisp type) 88 | `(cffitype->lisp ,type)))) 89 | (if (has-feature-p :use-lisp-arrays) 90 | `(aref ,array-name ,index) 91 | ;; Use CFFI and foreign arrays. 92 | `(cffi:mem-aref ,array-name ,cffi-type-expr ,index)))) 93 | 94 | (defmacro ll-make-array (size type &key (initial-element 0 initial-element-supplied-p)) 95 | "Call this function to allocate a block of memory to hold SIZE 96 | elements of type TYPE. The :INITIAL-ELEMENT keyword, if a value 97 | is supplied with it, causes all elements of the block to be set 98 | to the given value (which is automatically coerced to the given 99 | type." 100 | (let* ((type-expr (if (constantp type) 101 | (cffitype->lisp type) 102 | `(cffitype->lisp ,type))) 103 | (initial-element-expr 104 | (if initial-element-supplied-p 105 | (if (and (constantp initial-element) 106 | (constantp type)) 107 | `(:initial-element ,(coerce initial-element type-expr)) 108 | `(:initial-element (coerce ,initial-element ,type-expr))) 109 | nil)) 110 | (static-alloc-expr 111 | (if (has-feature-p :static-arrays) 112 | #+allegro '(:allocation :static-reclaimable) 113 | #+gcl '(:static t) 114 | #+lispworks '(:allocation :static) 115 | #-(or allegro gcl lispworks) 116 | (error "You claim that your Lisp supports static (pinned) allocation of arrays, but I don't know how to allocate static arrays in your Lisp. Please fill in the appropriate code here.") 117 | ;; no static arrays 118 | nil))) 119 | (if (has-feature-p :use-lisp-arrays) 120 | `(make-array ,size 121 | :element-type ,type-expr 122 | ,@initial-element-expr 123 | ,@static-alloc-expr) 124 | ;; Use C arrays. 125 | (if initial-element-supplied-p 126 | `(fill-foreign-array (cffi:foreign-alloc ,type-expr :count ,size) 127 | ,initial-element-expr) 128 | `(cffi:foreign-alloc ,type-expr :count ,size))))) 129 | 130 | 131 | ;;; #'cffi:foreign-free is the array finalization. 132 | ;;; Don't wrap it because that would introduce function call overhead. 133 | 134 | 135 | (defmacro ll-displaced-array (old-array type offset) 136 | "Returns the displaced 1-D array to OLD-ARRAY (of type TYPE) 137 | at index OFFSET. NOTE: for C pointers, you should never 138 | call free on the result of this macro call, because that 139 | memory is owned by another object." 140 | (let ((cffi-type-expr (if (constantp type) 141 | (lisptype->cffi type) 142 | `(lisptype->cffi ,type))) 143 | (cffi-type-size-expr 144 | (if (constantp type) 145 | (cffi:foreign-type-size (lisptype->cffi type)) 146 | `(cffi:foreign-type-size (lisptype->cffi ,type)))) 147 | (lisp-type-expr (if (constantp type) 148 | (quote (cffitype->lisp type)) 149 | `(cffitype->lisp ,type))) 150 | (static-alloc-expr 151 | (if (has-feature-p :static-arrays) 152 | #+allegro '(:allocation :static-reclaimable) 153 | #+gcl '(:static t) 154 | #+lispworks '(:allocation :static) 155 | #-(or allegro gcl lispworks) 156 | (error "Don't know how to make static arrays in your lisp")) 157 | nil)) 158 | (if (has-feature-p :use-lisp-arrays) 159 | `(make-array (- (array-dimension ,old-array 0) ,offset) 160 | ,@static-alloc-expr 161 | :element-type ,lisp-type-expr 162 | :displaced-to ,old-array 163 | :displaced-index-offset ,offset) 164 | ;; Use C arrays. 165 | `(cffi:inc-pointer ,old-array (* ,offset ,cffi-type-size-expr))))) 166 | 167 | -------------------------------------------------------------------------------- /src/experimental/element-access.lisp: -------------------------------------------------------------------------------- 1 | ;;; Time-stamp: <2008-05-20 18:12:38 Evan Monroig> 2 | ;;; 3 | ;;; Here I made several experiments to see how to improve vector and 4 | ;;; matrix element access. 5 | ;;; 6 | ;;; 7 | 8 | (in-package :lisp-matrix) 9 | 10 | (import 'cl-utilities:once-only) 11 | (import 'cl-utilities:with-unique-names) 12 | 13 | (defconstant +asize+ 4000000) 14 | (declaim (type fixnum +asize+)) 15 | 16 | 17 | (defun lisp-matrix-vref-benchmark () 18 | (let ((a (make-vector +asize+ 'double :initial-element 1d0)) 19 | (s 0d0)) 20 | (declare (type double-float s) 21 | (type vector-double a)) 22 | (dotimes (i +ASIZE+ s) 23 | (declare (type fixnum i)) 24 | (incf s (vref a i))))) 25 | 26 | #+nil 27 | (time (lisp-matrix-vref-benchmark)) 28 | ;; => 0.727 s 29 | 30 | ;;; 1) Return a lambda function. 31 | ;;; 32 | ;;; This was to see the difference in cost between the generic VREF 33 | ;;; and a VREF using a normal function call 34 | 35 | (defmethod vref-lambda ((a vector-double)) 36 | (declare (optimize (speed 3) (safety 0) (debug 0))) 37 | (lambda (a i) 38 | (declare (type fixnum i) 39 | (type vector-double a)) 40 | (the double-float (fnv-double-ref (data a) i)))) 41 | 42 | (defun lisp-matrix-vref-lambda-benchmark () 43 | (declare (optimize (speed 3) (safety 0) (debug 0))) 44 | (let ((a (make-vector +asize+ 'double :initial-element 1d0)) 45 | (s 0d0)) 46 | (declare (type double-float s) 47 | (type vector-double a)) 48 | (let ((vref (vref-lambda a))) 49 | (declare (type function vref)) 50 | (dotimes (i +asize+ s) 51 | (declare (type fixnum i)) 52 | (incf s (the double-float (funcall vref a i))))))) 53 | 54 | #+nil 55 | (time (lisp-matrix-vref-lambda-benchmark)) 56 | ;; => 0.353 s 57 | 58 | ;;; 2) Use a mapping operator. 59 | ;;; 60 | ;;; Basically the cost is the same as above. Instead of having a call 61 | ;;; to VREF each time, we have instead a call to the function to 62 | ;;; execute on the current element. 63 | 64 | (defmethod mapc-matrix (function (a vector-double)) 65 | (declare (optimize (speed 3) (safety 0) (debug 0))) 66 | (dotimes (i (nelts a)) 67 | (declare (type fixnum i)) 68 | (funcall function (fnv-double-ref (data a) i)))) 69 | 70 | (defun lisp-matrix-mapc-matrix-benchmark () 71 | (declare (optimize (speed 3) (safety 0) (debug 0))) 72 | (let ((a (make-vector +asize+ 'double :initial-element 1d0)) 73 | (s 0d0)) 74 | (declare (type double-float s) 75 | (type vector-double a)) 76 | (mapc-matrix (lambda (elt) 77 | (declare (type double-float elt)) 78 | (incf s elt)) 79 | a) 80 | s)) 81 | 82 | #+nil 83 | (time (lisp-matrix-mapc-matrix-benchmark)) 84 | ;; => 0.532 s 85 | 86 | ;;; 3) Crazy compiler macros 87 | ;;; 88 | ;;; By parsing the environment parameter of the compiler macro, we can 89 | ;;; do some limited type inference (directly from type declarations) 90 | ;;; to optimize away the generic function call. 91 | ;;; 92 | ;;; This is not portable, because you need to ask your lisp to give 93 | ;;; you information about type declarations from the environment 94 | ;;; object, which was not standardized. I experimented with sbcl, and 95 | ;;; I suspect that other lisps probably have constructs to do this, 96 | ;;; but it's probably not worth it right now. 97 | ;;; 98 | ;;; It works but in the expansion there is another generic function 99 | ;;; call to DATA anyway so it just halves the execution time of the 100 | ;;; benchmark in `benchmarks/lisp-vs-c-aref.lisp'. 101 | ;;; 102 | ;;; The conclusion is that VREF or MREF is not the right place to do 103 | ;;; the optimization - better have a macro 104 | 105 | 106 | #+sbcl 107 | (defun lexenv-get-type (symbol env) 108 | (assert (typep symbol 'symbol)) 109 | (let ((lambda-var 110 | (cdr (assoc symbol (sb-c::lexenv-vars env))))) 111 | (and lambda-var 112 | (typep lambda-var 'sb-c::lambda-var) 113 | (sb-c::lambda-var-type lambda-var)))) 114 | 115 | (defun test-type (form type env) 116 | "helper function for compiler macros - test that FORM is of the 117 | given type, either directly if it is an object, or if there is 118 | a (THE ...) form, or through lexical bindings in the environment 119 | ENV." 120 | (typecase form 121 | (list (and (eql (first form) 'the) 122 | (equal (second form) type) 123 | (not (null (third form))))) 124 | (symbol (let ((env-type (lexenv-get-type form env))) 125 | (and (subtypep env-type type) 126 | (subtypep type env-type)))) 127 | (atom (typep form type)) 128 | (t nil))) 129 | 130 | (define-compiler-macro vref (&whole form x i &environment env) 131 | ;; PRINT is there so that we can see what VREF is expanded into when 132 | ;; it is used in a function definition 133 | (cond ((test-type x 'vector-double env) 134 | (print 135 | (let ((fnv-array (gensym "FNV-ARRAY"))) 136 | `(let ((,fnv-array (data ,x))) 137 | (declare (type fixnum ,i) 138 | (type fnv-double ,fnv-array)) 139 | (the double-float 140 | (fnv-double-ref ,fnv-array ,i)))))) 141 | (t (print form)))) 142 | 143 | (defun lisp-matrix-vref-benchmark () 144 | (let ((a (make-vector +asize+ 'double :initial-element 1d0)) 145 | (s 0d0)) 146 | (declare (type double-float s) 147 | (type vector-double a)) 148 | (dotimes (i +ASIZE+ s) 149 | (declare (type fixnum i)) 150 | (incf s (vref a i))))) 151 | 152 | #+nil 153 | (time (lisp-matrix-vref-benchmark)) 154 | ;; => 0.243 s 155 | 156 | #|| 157 | 158 | (let ((a (make-vector 2 'double))) 159 | (funcall (compiler-macro-function 'vref) 160 | `(vref ,a 0) 161 | nil)) 162 | 163 | (let ((a (make-vector 2 'float))) 164 | (funcall (compiler-macro-function 'vref) 165 | `(vref ,a 0) 166 | nil)) 167 | 168 | (funcall (compiler-macro-function 'vref) 169 | `(vref ,(make-vector 2 'double) 0) 170 | nil) 171 | 172 | ||# 173 | 174 | ;;; Now I messed up the VREF generic, so before continuing I'll put it 175 | ;;; back. 176 | 177 | (define-compiler-macro vref (&whole form x i) 178 | (declare (ignore x i)) 179 | form) 180 | 181 | 182 | ;;; 4) higher-level macro 183 | ;;; 184 | ;;; The idea is to have a macro `with-fast-access' that inlines the 185 | ;;; calls to VREF and MREF for appropriate matrix types. There are a 186 | ;;; few possibilities to do this: (i) evaluate the code once we know 187 | ;;; the matrix type, i.e. at runtime; (ii) include type declarations 188 | ;;; in the macro. 189 | ;;; 190 | ;;; With (ii), a call to the macro might look like this 191 | 192 | #+nil 193 | (let ((a (make-vector 10 'double :initial-element 1d0)) 194 | (s 0d0)) 195 | (with-fast-access ((a vector-double)) 196 | (dotimes (i 10) 197 | (incf s (vref a i)))) 198 | s) 199 | 200 | ;;; which would be expanded to 201 | 202 | #+nil 203 | (let ((a (make-vector 10 'double :initial-element 1d0)) 204 | (s 0d0)) 205 | (let ((DATA1 (data a))) 206 | (dotimes (i 10) 207 | (declare (type fixnum i)) 208 | (incf s (the double-float (fnv-double-ref DATA1 i)))) 209 | s)) 210 | 211 | ;;; Here is a try at this using LABELS and MACROLET to rebind the 212 | ;;; function VREF. This won't work for (SETF VREF), and macros 213 | ;;; WITH-FAST-ACCESS can't be nested. 214 | ;;; 215 | ;;; Note: this looks similar to what Cyrrus Harmon did in his CLEM 216 | ;;; package, who solved the problem of not working with SETF by 217 | ;;; expanding in all cases (instead of falling back to the previous 218 | ;;; VREF), and nesting by having a symbol-macrolet store the variables 219 | ;;; for which to enable fast access. 220 | ;;; 221 | ;;; A full-fledged version would use a code walker but that's another 222 | ;;; can of worms.. 223 | 224 | (defmethod vref-call ((type (eql 'vector-double)) data-var i-var) 225 | ``(the double-float (fnv-double-ref ,',data-var ,,i-var))) 226 | 227 | (defmacro with-fast-access ((&rest forms) &body body) 228 | "Inline all calls to VREF or AREF in BODY for each vector or matrix 229 | in FORMS. 230 | 231 | This works by first binding a function to the old VREF function, and 232 | then defining a local macro VREF which expands into optimized code 233 | for each matrix in FORMS, and falls back to the function otherwise." 234 | (with-unique-names (a i vref) 235 | (loop for (var type) in forms 236 | for g = (gensym "DATA") 237 | collect `(,g (data ,var)) into data-bindings 238 | collect `(,var ,(vref-call type g i)) into vref-cases 239 | finally 240 | (return `(let (,@data-bindings) 241 | (labels ((,vref (,a ,i) (vref ,a ,i))) 242 | (declare (inline ,vref)) 243 | (macrolet ((vref (,a ,i) 244 | (case ,a 245 | ,@vref-cases 246 | (t `(,',vref ,,a ,,i))))) 247 | ,@body))))))) 248 | 249 | (defun lisp-matrix-fast-vref-benchmark () 250 | "Here we use the macro WITH-FAST-ACCESS which inlines calls to 251 | VREF." 252 | (let ((a (make-vector +asize+ 'double :initial-element 1d0)) 253 | (s 0d0)) 254 | (declare (type double-float s) 255 | (type vector-double a)) 256 | (with-fast-access ((a vector-double)) 257 | (dotimes (i +asize+ s) 258 | (declare (type fixnum i)) 259 | (incf s (vref a i)))))) 260 | 261 | #+nil 262 | (time (lisp-matrix-fast-vref-benchmark)) 263 | ;; => 0.074 s 264 | 265 | (defun lisp-matrix-fast-vref-benchmark2 () 266 | "same as LISP-MATRIX-FAST-VREF-BENCHMARK but we `forgot' to add the 267 | matrix in the list of matrices to optimize fast access for and 268 | thereby fall back to the rebound version of VREF (macro-expand the 269 | macro WITH-FAST-ACCESS in this function and in 270 | LISP-MATRIX-FAST-VREF-BENCHMARK to see the difference)." 271 | (let ((a (make-vector +asize+ 'double :initial-element 1d0)) 272 | (s 0d0)) 273 | (declare (type double-float s) 274 | (type vector-double a)) 275 | (with-fast-access () 276 | (dotimes (i +asize+ s) 277 | (declare (type fixnum i)) 278 | (incf s (vref a i)))))) 279 | 280 | #+nil 281 | (time (lisp-matrix-fast-vref-benchmark2)) 282 | ;; => 0.723 s 283 | -------------------------------------------------------------------------------- /src/experimental/features.lisp: -------------------------------------------------------------------------------- 1 | ;;;; features.lisp 2 | ;;;; Author: mfh 3 | ;;;; Last modified: 15 Oct 2006 4 | ;;;; 5 | ;;;; Management of features that are specific to each Lisp 6 | ;;;; implementation. 7 | ;;;; 8 | 9 | ;;; Supported features. These are keywords, and could include 10 | ;;; the following: 11 | ;;; 12 | ;;; :can-pause-gc -- the GC can be paused during the execution of a form. 13 | ;;; :static-arrays -- arrays can be "pinned" in memory on creation. 14 | ;;; :finalization -- a function can be called on GC of an object. 15 | ;;; :use-lisp-arrays -- we're using Lisp arrays and not C arrays 16 | ;;; 17 | ;;; We start with NIL and push features on depending upon which 18 | ;;; Lisp implementation we are using. 19 | (defparameter *our-features* nil) 20 | 21 | (defun add-feature (feature) 22 | (push feature *our-features*)) 23 | 24 | (defun add-features (&rest features) 25 | "Adds the given FEATURES to the features list." 26 | (loop for f in features do (add-feature f) finally (return nil))) 27 | 28 | ;;; FIXME: These lists aren't all complete. In particular, I don't 29 | ;;; have documentation for SCL. 30 | 31 | #+allegro 32 | (add-features :use-lisp-arrays :static-arrays :finalization) 33 | #+clisp 34 | (add-features :finalization) 35 | #+(or cmu sbcl) 36 | (add-features :can-pause-gc :finalization) 37 | #+corman 38 | (add-features :finalization) 39 | #+ecl 40 | (add-features :finalization) 41 | #+gcl 42 | (add-features :use-lisp-arrays :can-pause-gc :static-arrays :finalization) 43 | #+lispworks 44 | (add-features :use-lisp-arrays :static-arrays :can-pause-gc :finalization) 45 | #+openmcl 46 | (add-features :can-pause-gc :finalization) 47 | #+scl 48 | (add-features :finalization) ; I don't know what other features should be here 49 | #-(or allegro clisp cmu corman ecl gcl lispworks openmcl sbcl scl) 50 | (error "I don't know anything about your Lisp and I don't want to assume anything either. You should add an entry here for your own Lisp, filling in the features that it implements.") 51 | 52 | (defun has-feature-p (feature) 53 | "Returns non-nil iff our Lisp implementation implements the given FEATURE." 54 | (member feature *our-features*)) 55 | -------------------------------------------------------------------------------- /src/experimental/fixed-types.lisp: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;;; It's easier to unroll a DOTIMES than it is to unroll a general 4 | ;;; LOOP or ITERATE macro. DOTIMES looks like 5 | ;;; (DOTIMES (var bound [optional-return-value]) &body) 6 | ;;; 7 | ;;; FIXME: what about declarations in the body? Those will break 8 | ;;; the code below. 9 | (defmacro unroll-dotimes (the-dotimes) 10 | (destructuring-bind (var bound &optional retval) 11 | (cadr the-dotimes) 12 | (assert (constantp bound) "The bound in DOTIMES must be a constant in order to apply UNROLL-DOTIMES to it.") 13 | (let ((unrolled-body 14 | `(progn 15 | ,(loop for i from 0 to #.(1- bound) appending 16 | (list* @,body (incf ,var)))))) 17 | `(let ((,var 0)) 18 | (declare (type ,var fixnum)) 19 | ,unrolled-body)))) 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | ;;; LU factorization code generator. Generates LU factorization 28 | ;;; routines that factor the matrix in place using partial pivoting. 29 | ;;; The goal is to produce fully unrolled factorization routines, 30 | ;;; though that can increase code size a lot. For now we just 31 | ;;; produce loops. 32 | (defmacro generate-lu!-factorization (matsize) 33 | (let ((macro-name (format "lu~Ax~A!" ,matsize ,matsize))) 34 | `(defmacro ,macro-name (A pivarray) 35 | `(dotimes (j #.,matsize) 36 | (declare (type j fixnum)) 37 | (declare (type ,pivarray (simple-array fixnum #.,matsize))) 38 | ;; Find max pivot 39 | (let ((pivrow 40 | (loop with m = (aref ,A i j) 41 | with pivrow = j of-type fixnum 42 | for i of-type fixnum from (1+ j) to #.(1- ,matsize) 43 | finally (return pivrow) 44 | do 45 | (let ((m2 (abs (aref ,A i j)))) 46 | (when (> m2 m) 47 | (setv m m2) 48 | (setv pivrow i)))))) 49 | (progn 50 | (setf (aref ,pivarray j) pivrow) 51 | ;; Swap row j and row pivrow 52 | (when (/= pivrow j) 53 | (loop for i of-type fixnum from j to #.(1- ,matsize) do 54 | (let ((temp (aref ,A j i))) 55 | (setf (aref ,A j i) (aref ,A pivrow i)) 56 | (setf (aref ,A pivrow i) temp)))) 57 | ;; Assume that the pivot is nonzero and scale. 58 | (let ((pivot (aref ,A j j))) 59 | (loop for i from (1+ j) to #.(1- ,matsize) do 60 | (setf (aref ,A i j) (/ (aref ,A i j) pivot)))) 61 | ;; Update the remaining submatrix. 62 | (loop for i of-type fixnum from (1+ j) to #.(1- ,matsize) do 63 | (loop for k of-type fixnum from (1+ j) to #.(1- ,matsize) do 64 | (setf (aref ,A i k) 65 | (- (aref ,A i k) (* (aref ,A i j) (aref ,A j k)))))) 66 | ;; Return a list whose first element is the factored matrix 67 | ;; A, and whose second element is the pivot array. This avoids 68 | ;; the need for multiple-value-bind, and the LU solver macro can 69 | ;; destructure the list itself. 70 | (list ,A ,pivarray))))))) 71 | 72 | (dolist (s *fixed-sizes*) 73 | (generate-lu!-factorization s)) 74 | 75 | (defmacro generate-lu!-solver (matsize) 76 | (let ((macro-name (format nil "lusolve~Ax~A!" ,matsize ,matsize))) 77 | `(defmacro ,macro-name (x (LU pivarray) b) 78 | `(progn 79 | ;; Apply the permutation to b, storing the result in x. 80 | (loop for i of-type fixnum from 0 to #.(1- ,matsize) 81 | do (setf (aref ,x i) (aref ,b (aref ,pivarray i)))) 82 | ;; Solve PLc = Pb, storing the result in x. 83 | (loop for i of-type fixnum from 0 to #.(1- ,matsize) 84 | do (loop for j of-type fixnum from 0 to (1- i) 85 | do (setf (aref ,x i) (- (aref ,x i) (* (aref ,LU i j) (aref ,x j)))))) 86 | ;; Solve Ux = c, storing the result in x. 87 | (loop for i of-type fixnum from #.(1- ,matsize) downto 0 do 88 | (loop for j of-type fixnum from #.(1- ,matsize) downto (1+ i) do 89 | (setf (aref ,x i) (- (aref ,x i) (* (aref ,LU i j) (aref ,x j))))) 90 | (setf (aref ,x i) (/ (aref ,x i) (aref ,LU j j)))) 91 | ;; Return x. 92 | ,x)))) 93 | 94 | (dolist (s *fixed-sizes*) 95 | (generate-lu!-solver s)) 96 | 97 | 98 | 99 | ;;;; Now you can say (lusolve4x4! x (lu4x4! A pivarray) b) and it returns the right answer (???). 100 | -------------------------------------------------------------------------------- /src/experimental/gc.lisp: -------------------------------------------------------------------------------- 1 | ;;;; gc.lisp 2 | ;;;; Author: mfh 3 | ;;;; 4 | ;;;; Macros and functions dealing with manipulating the GC. 5 | ;;;; Needs: features.lisp 6 | ;;;; 7 | 8 | 9 | (defmacro with-gc-off (&body body) 10 | "If your Lisp supports it, pauses the GC during execution 11 | of BODY, and restores it afterwards." 12 | #+cmucl 13 | `(sys:without-gcing ,@body) 14 | #+sbcl 15 | `(sb-sys:without-gcing ,@body) 16 | #-(or cmucl sbcl) 17 | (let ((stop-gc-expr 18 | #+gcl 19 | `(si:sgc-on nil) 20 | #+openmcl 21 | `(egc nil) 22 | #+lispworks 23 | (progn 24 | (warn "AVOID-GC in LispWorks isn't guaranteed to prevent a GC") 25 | `(avoid-gc)) 26 | #-(or gcl openmcl lispworks) 27 | (error "I don't know how to turn off the GC in your Lisp")) 28 | (start-gc-expr 29 | #+gcl 30 | `(si:sgc-on t) 31 | #+openmcl 32 | `(egc t) 33 | #+lispworks 34 | (normal-gc) 35 | #-(or gcl openmcl lispworks) 36 | (error "I don't know how to turn on the GC in your Lisp"))) 37 | `(unwind-protect 38 | (progn 39 | ,stop-gc-expr 40 | ,@body) 41 | ,start-gc-expr))) 42 | 43 | (defun must-pause-gc () 44 | "Returns T iff we have to pause GC when passing one of our arrays 45 | (not any old user array) into a foreign function." 46 | (and (has-feature-p :can-pause-gc) 47 | (not (has-feature-p :static-arrays)) 48 | (has-feature-p :use-lisp-arrays))) 49 | 50 | (defmacro with-array-protection (&body body) 51 | "If needed, protects arrays from garbage collection during the 52 | execution of BODY. If not needed, wraps BODY in a PROGN." 53 | (if (must-pause-gc) 54 | `(with-gc-off 55 | ,@body) 56 | `(progn 57 | ,@body))) 58 | 59 | -------------------------------------------------------------------------------- /src/experimental/index-list-matview.lisp: -------------------------------------------------------------------------------- 1 | ;;;; INDEX-LIST-MATVIEW 2 | 3 | ;;; No offsets here; the stored indices carry that information. 4 | ;;; The elements in the matview have indices 5 | ;;; (row-indices[0], col-indices[0]), 6 | ;;; (row-indices[1], col-indices[1]), 7 | ;;; etc. This means (= (length row-indices) (length col-indices)). 8 | ;;; It's like coordinate storage of a sparse matrix. 9 | ;;; 10 | ;;; nrows and ncols are useful for matrix-matrix multiplication 11 | ;;; and the like. 12 | (defclass index-list-matview (matview) 13 | ((row-indices :initform (error "Must supply a vector of row indices") 14 | :initarg :row-indices 15 | :reader row-indices) 16 | (col-indices :initform (error "Must supply a vector of column indices") 17 | :initarg :col-indices 18 | :reader col-indices))) 19 | 20 | (defmethod initialize-instance :after ((A index-list-matview) &key) 21 | (with-slots (nrows ncols dim0 dim1 row-indices col-indices) A 22 | (assert (= (array-rank row-indices) 1)) 23 | (assert (= (array-rank col-indices) 1)) 24 | (assert (= (array-total-size row-indices) 25 | (array-total-size col-indices))) 26 | ;; We also check if the indices are in range. 27 | (loop 28 | for i across row-indices 29 | for j across col-indices 30 | do (assert (and (>= i 0) (< i dim0))) 31 | (assert (and (>= j 0) (< j dim1)))))) 32 | 33 | (defun apply-stride-to-indices (indices stride) 34 | "Returns a vector (indices[0], indices[0+stride], ...)" 35 | (let ((len (/ (array-total-size indices) stride))) 36 | (assert (integerp len)) 37 | (if (= 0 len) 38 | (make-array 0) 39 | (let ((result (make-array len :element-type (type-of (aref indices 0))))) 40 | (dotimes (i len result) 41 | (when (= (floor i stride) (/ i stride)) 42 | (setf (aref result (floor i stride)) (aref indices i)))))))) 43 | 44 | ;;; This is a special case: a strided subview of an index-list 45 | ;;; matview is an index-list matview. 46 | (defmethod strided-subview ((A index-list-matview) 47 | &key :nrows :ncols 48 | :offset0 :offset1 49 | :stride0 :stride1) 50 | (make-instance 'index-list-matview 51 | :my-array (slot-value A 'my-array) 52 | :nrows nrows 53 | :ncols ncols 54 | :dim0 (slot-value A 'dim0) 55 | :dim1 (slot-value A 'dim1) 56 | :row-indices (apply-stride-to-indices (slot-value A 'row-indices) stride0) 57 | :col-indices (apply-stride-to-indices (slot-value A 'col-indices) stride1))) 58 | 59 | (defun indices-are-unit-stride-p (indices) 60 | "Returns T if the differences between consecutive elements in the given integer vector INDICES are all one." 61 | (block returning-place 62 | (let ((S (scan 'vector indices))) 63 | (collect-fn 'integer 64 | #'(lambda () t) 65 | ;; Short-circuiting check for all ones. 66 | #'(lambda (prev cur) (if (/= cur 1) 67 | (return-from returning-place nil) 68 | t)) 69 | ;; Generate a series of differences between consecutive 70 | ;; elements. If all the elements in this series are one, 71 | ;; the indices are unit-stride. 72 | (map-fn 'integer #'- S 73 | (previous S (1- (collect-first S)))))))) 74 | 75 | (defmethod unit-stride-p ((A index-list-matview)) 76 | (and (indices-are-unit-stride-p (slot-value A 'row-indices)) 77 | (indices-are-unit-stride-p (slot-value A 'col-indices)))) 78 | 79 | (defmethod matview-index-to-1d-index ((A index-list-matview) i j) 80 | (with-slots (offset0 offset1 orientation 81 | dim0 dim1 row-indices col-indices) A 82 | (cond ((eql orientation :column) 83 | (+ offset0 (aref row-indices i) 84 | (* dim0 (+ offset1 (aref col-indices j))))) 85 | ((eql orientation :row) 86 | (+ offset1 (aref col-indices j) 87 | (* dim1 (+ offset0 (aref row-indices i))))) 88 | (t (error "Invalid orientation ~A" orientation))))) 89 | 90 | 91 | (defmethod scan-matview ((A index-list-matview)) 92 | (with-slots (my-array nrows ncols orientation 93 | dim0 dim1 row-indices col-indices) A 94 | (cond ((= 0 (* nrows ncols)) #Z()) 95 | ((eql orientation :column) 96 | (producing (w) ((i 0) (j 0)) 97 | (loop 98 | (tagbody 99 | (when (>= j ncols) 100 | (incf i)) 101 | (when (>= i nrows) 102 | (terminate-producing)) 103 | (next-out w (aref my-array 104 | (aref row-indices i) 105 | (aref col-indices j))) 106 | (incf j))))) 107 | ((eql orientation :row) 108 | (producing (w) ((i 0) (j 0)) 109 | (loop 110 | (tagbody 111 | (when (>= i nrows) 112 | (incf j)) 113 | (when (>= j ncols) 114 | (terminate-producing)) 115 | (next-out w (aref my-array 116 | (aref row-indices i) 117 | (aref col-indices j))) 118 | (incf i))))) 119 | (t (error "Invalid orientation ~A" orientation))))) 120 | 121 | (defmethod transpose ((A index-list-matview)) 122 | (make-instance index-list-matview 123 | :my-array (slot-value A 'my-array) 124 | :nrows (slot-value A 'ncols) 125 | :ncols (slot-value A 'nrows) 126 | :orientation (opposite-orientation (slot-value A 'orientation)) 127 | :dim0 (slot-value A 'dim1) 128 | :dim1 (slot-value A 'dim0) 129 | :offset0 (slot-value A 'offset1) 130 | :offset1 (slot-value A 'offset0) 131 | :row-indices (slot-value A 'col-indices) 132 | :col-indices (slot-value A 'row-indices))) 133 | 134 | 135 | (defmethod restore ((OUT index-list-matview) (IN matrix))) 136 | 137 | 138 | -------------------------------------------------------------------------------- /src/experimental/mangle.lisp: -------------------------------------------------------------------------------- 1 | ;;;; mangle.lisp 2 | ;;;; Author: mfh 3 | ;;;; Date: 15 Oct 2006 4 | ;;;; Last modified: 19 Oct 2006 5 | ;;;; 6 | ;;;; Functions for name-mangling, for a template system similar to 7 | ;;;; that of C++ (except that it uses CLOS). The mangling system 8 | ;;;; is independent of the template system except when MANGLED-NAME 9 | ;;;; needs to output an error message, at which point it searches 10 | ;;;; the TEMPLATES package for a *TEMPLATE-TYPES* symbol. But we 11 | ;;;; don't need a (USE-PACKAGE "TEMPLATES") or even to have loaded 12 | ;;;; the templates implementation yet. 13 | ;;;; 14 | ;;;; The mangling system is also package-friendly: different 15 | ;;;; packages have different mangling systems that are separate and 16 | ;;;; guaranteed not to clash. 17 | ;;;; 18 | ;;;; There are a number of parameters for tuning the mangling 19 | ;;;; system, which are documented DEFCONSTANTs in the code below. 20 | ;;;; 21 | 22 | (defpackage :mangle 23 | (:use :common-lisp) 24 | (:export :mangled-p 25 | :mangle 26 | :mangled-name)) 27 | 28 | (in-package :mangle) 29 | 30 | ;;; Length of the random symbol used for name mangling. 31 | (defconstant +random-symbol-length+ 10) 32 | 33 | ;;; Characters for the name mangling are picked randomly 34 | ;;; from this set, which is stored as a string (character array). 35 | (defconstant +char-table+ #.(concatenate 'string 36 | "0123456789abcdefghijklmnopqrst" 37 | "uvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")) 38 | ;;; Length of the above character table. 39 | (defconstant +char-table-len+ (length +char-table+)) 40 | 41 | 42 | (defun random-mangling-string () 43 | "Produces a random string of a fixed length, for use in name mangling." 44 | (let ((s (make-string +random-symbol-length+))) 45 | (loop for i from 0 upto (1- +random-symbol-length+) do 46 | (declare (type fixnum +random-symbol-length+ +char-table-len+ i)) 47 | (declare (type string s)) 48 | (setf (char s i) (char +char-table+ (random +char-table-len+))) 49 | finally return s))) 50 | 51 | 52 | 53 | ;;;;;; TODO: get the SERIES package. 54 | ;;;(let* (;; Length of the random symbol used for name mangling. 55 | ;;; (+random-symbol-length+ 10) 56 | ;;; ;; Characters are picked randomly from this set. 57 | ;;; (+char-table+ "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") 58 | ;;; (+char-table-len+ (length +char-table+))) 59 | ;;; (defun random-mangling-string () 60 | ;;; "Produces a random string of a fixed length, for use in name mangling." 61 | ;;; (collect 'string 62 | ;;; (map-fn 'char 63 | ;;; #'(lambda (i) 64 | ;;; (declare (ignorable i)) 65 | ;;; (char +char-table+ (random +char-table-len+))) 66 | ;;; (scan-range :length +random-symbol-length+))))) 67 | 68 | ;;; type-list is (cons classname template-value-list) or just classname 69 | ;;; if there are no template values. 70 | (defun produce-instantiated-symbol-name (manglage type-list) 71 | (if (atom type-list) 72 | (format nil "~A-~A" type-list manglage) 73 | (reduce #'(lambda (x y) (concatenate 'string x "-" y)) 74 | (append (mapcar #'symbol-name type-list) 75 | (list manglage))))) 76 | 77 | 78 | ;;; Hash table keying from package name to hash table, which keys 79 | ;;; from mangled name to unmangled type. For example: 80 | ;;; 81 | ;;; COMMON-LISP -> 82 | ;;; ('matrix-double-float-123456 -> (list 'matrix 'double-float)) 83 | ;;; 84 | ;;; It can use EQ as the test because the keys are symbols. We 85 | ;;; start with :SIZE 1 because there may only be one package for 86 | ;;; which we need a mangled->unmangled mapping. 87 | (defparameter *mangled->unmangled* (make-hash-table :test #'eq :size 1)) 88 | 89 | ;;; Hash table keying from package name to hash table, which keys 90 | ;;; from unmangled type to mangled name. For example: 91 | ;;; 92 | ;;; COMMON-LISP -> 93 | ;;; (matrix double-float) -> matrix-double-float-123456 94 | (defparameter *unmangled->mangled* (make-hash-table :test #'eq :size 1)) 95 | 96 | 97 | 98 | (defun mangled-p (type-list &key (package *package*)) 99 | "TYPE-LIST: either (CONS CLASSNAME TEMPLATE-VALUE-LIST, or CLASSNAME. 100 | The full name of the template type instantiation. 101 | PACKAGE: the package in which the given template type instantiation 102 | was possibly instantiated. 103 | 104 | Returns T iff the given template type instantiation has been 105 | instantiated in the given package." 106 | (multiple-value-bind (h is-there) 107 | (gethash package *unmangled->mangled*) 108 | (if is-there 109 | (multiple-value-bind (mangled is-there) 110 | (if (atomp type-list) 111 | (let ((classname type-list)) 112 | (gethash (list classname) h)) 113 | (gethash type-list h)) 114 | is-there) 115 | nil))) 116 | 117 | (defun mangled-name (type-list &key (package *package*)) 118 | "If (CLASSNAME TEMPLATE-VALUE-LIST) is an instantiated template type 119 | in PACKAGE, returns the corresponding mangled name. Otherwise, reports 120 | an informative error." 121 | (multiple-value-bind (u->m is-there) 122 | (gethash package *unmangled->mangled*) 123 | (if is-there 124 | ;; Package has instantiated generic types in it. 125 | (multiple-value-bind (mangled is-there) 126 | (if (atom type-list) 127 | (gethash type-list u->m) 128 | (gethash (cons classname template-value-list) u->m)) 129 | (if is-there 130 | ;; The given type has been instantiated; 131 | ;; return the mangled name. 132 | mangled 133 | ;; Mangling wasn't registered. Look up more info 134 | ;; to print a useful error message. EVERYTHING below 135 | ;; this point is for printing an error message. 136 | (let ((p->gts (find-symbol "*template-types*" "templates"))) 137 | (if (null p->gts) 138 | (error "BUG: failed to find template types lookup table!") 139 | (multiple-value-bind (gts is-there) 140 | (gethash package gts) 141 | (if is-there 142 | (multiple-value-bind (gt is-there) 143 | (gethash classname gt) 144 | (if is-there 145 | (if (atom type-list) 146 | (error (concatenate 'string 147 | "Template type ~A exists in package ~A, " 148 | "but has not yet been instantiated") 149 | type-list package) 150 | (error (concatenate 'string 151 | "Template type ~A exists in package ~A, " 152 | "but has not yet been instantiated with " 153 | "parameters ~A") (car type-list) 154 | package (cdr type-list))) 155 | (error "Template type ~A does not exist in package ~A" 156 | (if (atom type-list) type-list (car type-list)) 157 | package))) 158 | (error "No template types exist yet in package ~A" package))))))) 159 | (error "Package ~A contains no instantiated template types yet" package)))) 160 | 161 | 162 | (defun register-mangling-helper (m->u u->m type-list &key (package *package*)) 163 | "M->U: hash table (for the given PACKAGE) from mangled name to unmangled type. 164 | U->M: hash table (for the given PACKAGE) from unmangled type to mangled name. 165 | CLASSNAME: template type in package PACKAGE. 166 | PACKAGE: package in which to intern the mangled name. Defaults to the current 167 | package." 168 | 169 | (let ((type (if (atom type-list) (cons type-list nil) type-list)) 170 | (symb (intern mangled package))) 171 | (progn 172 | (setf (gethash symb m->u) type) 173 | (setf (gethash type u->m) symb) 174 | symb))) 175 | 176 | (defun register-mangling (mangled type-list &key (package *package*)) 177 | "Registers the mangled name MANGLED for the template type instantiation 178 | (CLASSNAME TEMPLATE-VALUE-LIST) in package PACKAGE." 179 | ;; This is more complicated than necessary so that we only 180 | ;; call GETHASH once for each table, if the hash tables m->u 181 | ;; and u->m are already set. 182 | (let ((m->u (gethash package *mangled->unmangled*)) 183 | (u->m (gethash package *unmangled->mangled*))) 184 | (cond ((null m->u) 185 | (setf (gethash package *mangled->unmangled) 186 | (make-hash-table :test #'eq)) 187 | (cond ((null u->m) 188 | (setf (gethash package *unmangled->mangled*) 189 | (make-hash-table :test #'equal)) 190 | (register-mangling-helper (gethash package *mangled->unmangled*) 191 | (gethash package *unmangled->mangled*) 192 | type-list :package package)) 193 | (t 194 | (register-mangling-helper (gethash package *mangled->unmangled*) 195 | u->m type-list :package package)))) 196 | (t 197 | (cond ((null u->m) 198 | (setf (gethash package *unmangled->mangled*) 199 | (make-hash-table :test #'equal)) 200 | (register-mangling-helper m->u 201 | (gethash package *unmangled->mangled*) 202 | type-list :package package)) 203 | (t 204 | (register-mangling-helper m->u u->m type-list 205 | :package package))))))) 206 | 207 | ;;; The MANGLE function generates mangled strings and tests to see 208 | ;;; if they are in the mangling database; if they are, it tries again. 209 | ;;; This is the total number of times that it tries before it signals 210 | ;;; an error. We insist on making this number non-infinite, in case 211 | ;;; +random-symbol-length+ is set too low or the random number 212 | ;;; generator is broken; we don't want the mangling system to cause 213 | ;;; an infinite loop! 214 | (defconstant +mangle-iteration-limit+ 10000) 215 | 216 | (defun mangle (type-list &key (package *package*)) 217 | "TYPE-LIST: either an atom CLASSNAME or a list (CONS CLASSNAME 218 | TEMPLATE-PARAMETER-LIST). The name of a template type 219 | instantiation, in which CLASSNAME is the template type. 220 | PACKAGE: the name of the package in which the template type 221 | instantiation is to be instantiated. 222 | 223 | Given a template type instantiation, finds and registers a 224 | corresponding mangled name, interning it in PACKAGE, and returns 225 | the mangled name. If the mangling has already been registered, 226 | just returns the mangled name." 227 | 228 | (if (mangled-p type-list :package package) 229 | ;; If we've already registered a mangled name, just return it. 230 | (mangled-name type-list :package package) 231 | (loop 232 | for count from 0 to +mangle-iteration-limit+ 233 | with symb = (produce-instantiated-symbol-name type-list 234 | (random-mangling-string)) 235 | while (find-symbol symb package) 236 | do 237 | (declare (type fixnum count +mangle-iteration-limit+)) 238 | (setf symb (produce-instantiated-symbol-name type-list 239 | (random-mangling-string))) 240 | finally returning 241 | (if (find-symbol symb package) 242 | (error (concatenate 'string 243 | "Failed to find unique symbol for name " 244 | "mangling of ~A after ~A iterations") 245 | type-list +mangle-iteration-limit+) 246 | (register-mangling symb type-list :package package))))) 247 | -------------------------------------------------------------------------------- /src/experimental/multiplication.lisp: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Time-stamp: <2008-06-07 15:54:15 Evan Monroig> 3 | 4 | ;;;; This is some experimental code to call the fortran dgemm using 5 | ;;;; CFFI types for which lisp arrays are converted inline (no generic 6 | ;;;; functions) -- this would necessitate to duplicate the work (and 7 | ;;;; the CFFI types) for the case of foreign arrays. 8 | 9 | 10 | (in-package :lisp-matrix) 11 | 12 | (asdf:oos 'asdf:load-op 'ffa) 13 | (asdf:oos 'asdf:load-op 'cl-utilities) 14 | 15 | (import '(blapack-cffi-types:fortran-int 16 | blapack-cffi-types:fortran-double)) 17 | 18 | (define-foreign-type lisp-array-double-type 19 | () 20 | () 21 | (:ACTUAL-TYPE :POINTER) 22 | (:SIMPLE-PARSER lisp-array-double)) 23 | 24 | (defmethod expand-to-foreign-dyn (value var body 25 | (type lisp-array-double-type)) 26 | (cl-utilities:once-only (value) 27 | `(ffa:with-pointer-to-array ((data ,value) ,var :double (nelts 28 | ,value) :copy-in) 29 | ,@body))) 30 | 31 | (defmethod gemm (alpha (a la-matrix-double) (b la-matrix-double) beta 32 | (c la-matrix-double)) 33 | (assert (= (ncols a) (nrows b))) 34 | (assert (= (nrows a) (nrows c))) 35 | (assert (= (ncols b) (ncols c))) 36 | (with-copies ((a (or (not unit-stride-p) 37 | (not zero-offset-p))) 38 | (b (or (not unit-stride-p) 39 | (not zero-offset-p))) 40 | (c (or (not unit-stride-p) 41 | (not zero-offset-p) 42 | transposed-p) 43 | t)) 44 | c 45 | (foreign-funcall "dgemm_" 46 | :string (orientation-letter a) 47 | :string (orientation-letter b) 48 | fortran-int (nrows a) 49 | fortran-int (ncols b) 50 | fortran-int (ncols a) 51 | fortran-double alpha 52 | lisp-array-double a 53 | fortran-int (real-nrows a) 54 | lisp-array-double b 55 | fortran-int (real-nrows b) 56 | fortran-double beta 57 | lisp-array-double c 58 | fortran-int (real-nrows c)))) 59 | -------------------------------------------------------------------------------- /src/experimental/templates.lisp: -------------------------------------------------------------------------------- 1 | ;;;; templates.lisp 2 | ;;;; Author: mfh 3 | ;;;; Created: 15 Oct 2006 4 | ;;;; Last modified: 19 Oct 2006 5 | ;;;; 6 | ;;;; A templated defclass mechanism somewhat like templates in C++. 7 | ;;;; Needs: mangle.lisp 8 | ;;;; 9 | ;;;; BUGS: Doesn't play nice with the class system yet. There are 10 | ;;;; some tricky problems to solve with the macrology. I think the 11 | ;;;; DEFMETHOD INSTANTIATE created by the macro needs to be a closure 12 | ;;;; with access to the original package variable from which the 13 | ;;;; macro was called. It could be a problem if the macro is called 14 | ;;;; in a different package from which the INSTANTIATE method is 15 | ;;;; called. 16 | ;;;; 17 | ;;;; UNTESTED! 18 | ;;;; 19 | 20 | (defpackage :templates 21 | (:use :common-lisp :mangle) 22 | (:export :register-template-type 23 | :template-type-p 24 | :defclass-template)) 25 | (in-package :templates) 26 | 27 | (defparameter *warnings* t) 28 | 29 | 30 | ;;; Hash table from package name, to set (implemented as a hash table) 31 | ;;; of generic classes in that package. 32 | (defparameter *template-types* (make-hash-table :test #'eq :size 1)) 33 | 34 | (defun register-template-type (type &key (package *package*)) 35 | "TYPE: either an atom CLASSNAME, or a list (CONS CLASSNAME TEMPLATE-PARAMETER-LIST). 36 | PACKAGE: a package in which to register TYPE as a template type. 37 | 38 | Registers TYPE as a template type in package PACKAGE. If TYPE is an atom, 39 | it is registered as a template type with no template parameters; if TYPE 40 | is a list, it is registered as a template type named (CAR TYPE) with template 41 | parameters (CDR TYPE)." 42 | (let ((classname (if (atom type) type (car type))) 43 | (tpl (if (atom type) nil (cdr type)))) 44 | (multiple-value-bind (h is-there) 45 | (gethash package *template-types*) 46 | (when (not is-there) 47 | (setf h (make-hash-table :test #'eq)) 48 | (setf (gethash package *template-types*) h)) 49 | (multiple-value-bind (old-tpl is-there) 50 | (gethash classname h) 51 | (when (and is-there *warnings*) 52 | (warn 53 | (concatenate 'string "Template class ~A has already been registered " 54 | "in package ~A with template parameter list ~A; now re-" 55 | "registering with template parameter list ~A") classname 56 | package old-tpl tpl)) 57 | (setf (gethash classname h) tpl) 58 | classname)))) 59 | 60 | 61 | (defun template-type-p (cl &key (package *package*)) 62 | "Returns T iff the given template type CL is a template class 63 | in package PACKAGE. CL is a symbol, not a list." 64 | (multiple-value-bind (h is-there) 65 | (gethash package *template-types*) 66 | (and is-there 67 | (multiple-value-bind (tpl is-there) 68 | (gethash cl h) 69 | is-there)))) 70 | 71 | 72 | (defun template-parameters (cl &key (package *package*)) 73 | "Returns the list of template parameters associated with the 74 | given template type CL." 75 | (multiple-value-bind (h is-there) 76 | (gethash package *template-types*) 77 | (if is-there 78 | (multiple-value-bind (tpl is-there) 79 | (gethash cl h) 80 | (if is-there 81 | tpl 82 | (error "Template type ~A not registered in package ~A" cl package))) 83 | (error "Package ~A has no template types registered in it" package)))) 84 | 85 | 86 | (defun find-mangled-name (type &key (package *package*)) 87 | "Returns the mangled name of the instantiation of TYPE 88 | in package PACKAGE." 89 | (if (template-type-p (if (atom type) type (car type)) package) 90 | (mangle:mangled-name type :package package) 91 | (error "Template type ~A is not registered as a template type in package ~A" 92 | (if (atom type) type (car type)) package))) 93 | 94 | 95 | (defun apply-macro (symb &rest args) 96 | (eval (cons symb args))) 97 | 98 | 99 | (defun two-lists-to-alist (L1 L2) 100 | "Returns the ALIST resulting from looping over both input lists 101 | and consing an element from the first list onto the corresponding 102 | element from the second list." 103 | (loop 104 | for x in L1 105 | for y in L2 106 | collect (cons x y))) 107 | 108 | (defmacro defclass-template (classname template-param-list super-list 109 | &body body) 110 | "Create a class template like this: 111 | 112 | (defclass-template foo (bar baz) (s) BODY) 113 | 114 | Now you can instantiate your class, setting bar to double-float 115 | and baz to 10, like this: 116 | 117 | (instantiate 'foo 'double-float 10) 118 | 119 | and the resulting class can be referred to as a 120 | '(foo double-float 10). (The actual type name is mangled, 121 | just like in C++, to prevent name collisions. The type 122 | name is sufficiently obscure that you probably won't choose 123 | it for one of your classes.) Note that unlike with C++, you 124 | have to instantiate your classes explicitly. 125 | 126 | Just like C++, there's a lot of code bloat -- a DEFCLASS 127 | for each datatype for which you instantiate a class. Code 128 | expands at macro-expansion time. 129 | 130 | You can also inherit from generic types, as long as those 131 | types have been instantiate with the type with which you 132 | want to instantiate this class. You can inherit from non- 133 | generic types too -- the macro can tell the difference by 134 | checking if the superclass is in the set of \"generic\" 135 | (not CLOS sense, but template sense) classes. 136 | 137 | The instantiator macro is interned in the package in which 138 | DEFCLASS-TEMPLATE is called, but the DEFCLASS and DEFTYPE 139 | are interned into the package in which the instantiator 140 | macro is called. 141 | 142 | BUGS: you can't remove generic classes and instantiated 143 | classes once you create them." 144 | (let ((class (gensym)) 145 | (package *package*)) 146 | (progn 147 | ;; Add the generic class to the set of generic classes. 148 | (register-template-type (cons classname template-param-list) :package package) 149 | 150 | `(progn 151 | (defmacro ,(intern (concatenate 'string "instantiate-" classname)) 152 | (&rest template-value-list) 153 | 154 | ;; Make sure that we've registered the generic class. 155 | (assert (template-type-p ,classname)) 156 | 157 | ;; Make sure that the number of template values to fill 158 | ;; in is the same as the number of template parameters 159 | ;; supplied to the generic class. 160 | (assert (= (length (template-parameters ,classname :package package)) 161 | (length template-value-list))) 162 | 163 | (with-gensyms (mangled the-super-list the-body) 164 | (let ((,mangled (mangle ,classname ,template-value-list)) 165 | (,the-super-list (mapcar #'(lambda (cl) 166 | (find-mangled-name 167 | (cons cl template-value-list))))) 168 | (,the-body (sublis (two-list-to-alist ,template-param-list 169 | template-value-list)))) 170 | `(progn 171 | (defclass ,mangled ,the-super-list ,the-body) 172 | (deftype ,classname ,template-param-list 173 | `,(mangled-name ,classname ,template-param-list)))))) 174 | 175 | ;; Create the INSTANTIATE method, EQL-specialized to the 176 | ;; generic class name. It just calls the associated macro. 177 | ;; We use the EVAL construct because we have to compute the 178 | ;; name of the instantiate- macro, and the only 179 | ;; way to call a macro whose name is computed is to call EVAL 180 | ;; (APPLY or FUNCALL don't work for macros). 181 | `(defmethod instantiate ((,class (eql ,classname)) 182 | &rest tvl) 183 | (templates::apply-macro ,(find-symbol (format nil 184 | "instantiate-~A" 185 | ,classname 186 | ,package)) 187 | ,@tvl)))))) 188 | 189 | -------------------------------------------------------------------------------- /src/experimental/types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; types.lisp 2 | ;;;; Author: mfh 3 | ;;;; 4 | ;;;; Functions for conversion between Lisp types and CFFI types. 5 | ;;;; Needs: CFFI 6 | ;;;; 7 | ;;;; FIXME: I should really use CFFI functions to do this, as the 8 | ;;;; exact type conversions depend on the particular Lisp 9 | ;;;; implementation. 10 | 11 | ;;; mfh 15 Oct 2006 12 | ;;; 13 | ;;; In CFFI, C structs cannot be passed by value. This excludes 14 | ;;; passing C99 / Fortran complex numbers around unless we do some 15 | ;;; serious hackery. In particular, defcstruct won't help us, nor 16 | ;;; will defcunion (as unions are implemented as structs in which all 17 | ;;; slots have an offset of zero). On 15 Oct 2006 I e-mailed 18 | ;;; cffi-devel@common-lisp.net to ask how hard it would be for us to 19 | ;;; add complex float datatypes to CFFI. As Lisp implementations 20 | ;;; themselves may not have complex float datatypes in their FFI's, 21 | ;;; this may require some bit twiddling (e.g. extracting an 22 | ;;; (unsigned-byte 128) and interpreting it as two double-floats). 23 | 24 | (defpackage :types 25 | (:use :common-lisp) 26 | (:export :lisptype->cffi :cffitype->lisp)) 27 | (in-package :types) 28 | 29 | 30 | (defun lisptype->cffi (type) 31 | "Given a Lisp floating-point (real or complex) value type, 32 | returns the corresponding CFFI type. If given the CFFI 33 | floating-point type, just returns that type." 34 | (cond ((or (eq type 'double-float) (eq type :double)) 35 | :double) 36 | ((or (eq type 'single-float) (eq type :float)) 37 | :float) 38 | (t (error "Unrecognized type ~A" type)))) 39 | 40 | (defun cffitype->lisp (type) 41 | "Given a CFFI floating-point (real or complex) value type, 42 | returns the corresponding Lisp type. If given the Lisp 43 | floating-point type, just returns that type." 44 | (cond ((or (eq type 'double-float) (eq type :double)) 45 | 'double-float) 46 | ((or (eq type 'single-float) (eq type :float)) 47 | 'single-float) 48 | (t (error "Unrecognized type ~A" type)))) 49 | 50 | -------------------------------------------------------------------------------- /src/experimental/utilities.lisp: -------------------------------------------------------------------------------- 1 | 2 | 3 | (defun array-in-place-transpose (A m n scratch) 4 | "A: array with m x n elements. 5 | m: number of columns in the original matrix. 6 | n: number of rows in the original matrix. 7 | scratch: scratch space array with space for n elements." 8 | (if (= m 1) 9 | nil 10 | (progn 11 | ;; Copy the old first row into the scratch space, 12 | ;; which stores the new first column. 13 | (dotimes (j n) 14 | (setf (aref scratch j) (aref A (* m j)))) 15 | ;; Shift the remaining elements over to the right (starting 16 | ;; from the right side), thus leaving a space of length m 17 | ;; on the left side. 18 | (let ((c (1- (* m n)))) 19 | (loop for j from (1- n) downto 0 do 20 | (loop for i from (1- m) downto 1 do 21 | (setf (aref A c) (aref A (+ i (* m j)))) 22 | (decf c)))) 23 | ;; In that space we've created, put the new first column. 24 | (dotimes (j n) 25 | (setf (aref A j) (aref scratch j))) 26 | ;; Recurse on the remaining submatrix. 27 | (array-in-place-transpose ((make-array (- (* m n) m) 28 | :displaced-to A 29 | :displaced-index-offset m) 30 | (1- m) n scratch))))) 31 | 32 | 33 | (defun find-in-tree (symb tree &optional (pred #'eq)) 34 | "Finds the given object SYMB in the given tree TREE, using the equality test PRED." 35 | (if (null tree) 36 | nil 37 | (if (funcall pred symb tree) 38 | tree 39 | (or (find-in-tree symb (car tree) pred) 40 | (find-in-tree symb (cdr tree) pred))))) 41 | 42 | ;;; Looks for a given symbol SYMB as the head of a list (i.e. in 43 | ;;; function position) in the structure of the given tree TREE. 44 | ;;; If found, returns the entire function call. 45 | (defun find-function-in-tree (symb tree) 46 | (if (atom tree) 47 | nil 48 | (if (eq (car tree) symb) 49 | tree 50 | (or (find-function-in-tree (car tree)) 51 | (find-function-in-tree (cdr tree)))))) 52 | -------------------------------------------------------------------------------- /src/experimental/vector-as-separate-type.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-matrix) 2 | 3 | ;;;; * Vectors 4 | ;;;; 5 | ;;;; Vector can be viewed as matrices that happen to have one row (or 6 | ;;;; one column), or as a separate type. 7 | ;;;; 8 | ;;;; One advantage of having vectors be subtypes of matrices is that 9 | ;;;; we don't need to re-specialize many generic functions (e.g., m*, 10 | ;;;; m+, m-, etc.), we can just use those that are defined for 11 | ;;;; matrices. 12 | ;;;; 13 | ;;;; However, a big disadvantage is that we will have lots of code 14 | ;;;; duplication (two times as many classes) for the separation of 15 | ;;;; row- and column-vectors. 16 | ;;;; 17 | ;;;; This is a try at defining vectors as a separate type. 18 | 19 | ;;;; ** Basic vector class 20 | 21 | (defclass vector-like () 22 | ((nelts :initarg :nelts 23 | :reader nelts 24 | :initform 0 25 | :documentation "Number of elements in this vector or vector 26 | view.")) 27 | (:documentation "Abstract base class for 1-D vectors and vector 28 | views.")) 29 | 30 | (defgeneric vector-dimension (vector) 31 | (:documentation "Like ARRAY-DIMENSION for vector-like objects.") 32 | (:method ((vector vector-like)) 33 | (nelts vector))) 34 | 35 | (defgeneric vref (vector i) 36 | (:documentation "Return the I-th element of VECTOR. This method is 37 | slow as it requires CLOS method dispatch and index calculation(s), 38 | and should thus be replaced with vectorized or block operations 39 | whenever possible")) 40 | 41 | (defgeneric (setf vref) (value vector i) 42 | (:documentation "Set the I-th element of VECTOR to VALUE. This 43 | method is slow as it requires CLOS method dispatch and index 44 | calculation(s), and should thus be replaced with vectorized or block 45 | operations whenever possible.")) 46 | 47 | (defmethod ancestor ((vector vector-like)) vector) 48 | 49 | ;;;; ** Vector views (VECVIEW) 50 | 51 | (defclass vecview (vector-like) 52 | ((parent :initarg :parent 53 | :reader parent 54 | :documentation "The \"parent\" object to which this vector 55 | view relates.")) 56 | (:documentation "An abstract class representing a \"view\" into a 57 | vector. That view may be treated as a (readable and writeable) 58 | reference to the elements of the vector.")) 59 | 60 | (defgeneric vecview-p (vector) 61 | (:documentation "Is VECTOR a VECVIEW?")) 62 | 63 | (defmethod ancestor ((vector vecview)) (ancestor (parent vector))) 64 | 65 | (defgeneric real-nelts (vector) 66 | (:documentation "Return the actual number of elements of the vector 67 | in which VECTOR is stored, namely the number of columns of the 68 | ancestor of VECTOR.") 69 | (:method ((vector vector-like)) (nelts vector)) 70 | (:method ((vector vecview)) (nelts (ancestor vector)))) 71 | 72 | (defclass slice-vecview (vecview) 73 | ((offset :initarg :offset 74 | :reader offset 75 | :initform 0) 76 | (stride :initarg :stride 77 | :reader stride 78 | :initform 1))) 79 | 80 | (defmethod unit-stride-p ((vector vector-like)) 81 | t) 82 | 83 | (defmethod unit-stride-p ((vector vecview)) 84 | (unit-stride-p (parent vector))) 85 | 86 | (defmethod unit-stride-p ((vector slice-vecview)) 87 | (and (= 1 (stride vector)) 88 | (unit-stride-p (parent vector)))) 89 | 90 | (defmethod vref ((vector slice-vecview) i) 91 | (vref (parent vector) 92 | (+ (offset vector) (* i (stride vector))))) 93 | 94 | (defmethod (setf vref) (value (vector slice-vecview) i) 95 | (setf (vref (parent vector) 96 | (+ (offset vector) (* i (stride vector)))) 97 | value)) 98 | 99 | ;;;; ** Creating vectors 100 | 101 | (defgeneric make-vector* (nelts implementation &key element-type 102 | initial-element) 103 | (:documentation "Create a vector holding NELTS elements of type 104 | ELEMENT-TYPE with IMPLEMENTATION as underlying implementation. 105 | INITIAL-ELEMENT is an element that may be used to initially fill the 106 | vector. 107 | 108 | If INITIAL-ELEMENT is not specified, the vector is not initialized, 109 | and accessing its elements will thus return spurious values.")) 110 | 111 | (defun make-vector (nelts &key 112 | (implementation *default-implementation*) 113 | (element-type *default-element-type*) 114 | (initial-element nil initial-element-p) 115 | (initial-contents nil initial-contents-p)) 116 | "Create a vector holding NELTS elements of type ELEMENT-TYPE with 117 | VECTOR-IMPLEMENTATION as underlying implementation. INITIAL-ELEMENT 118 | is an element that may be used to initially fill the vector. 119 | 120 | If INITIAL-ELEMENT is not specified, the vector is not initialized, 121 | and accessing its elements will thus return spurious values. 122 | 123 | If INITIAL-CONTENTS is specified, it is used to initialize the 124 | vector, by using the generic function COPY!. 125 | 126 | IMPLEMENTATION can be one of :LISP-ARRAY and :FOREIGN-ARRAY" 127 | (when (and initial-element-p initial-contents-p) 128 | (error "Both INITIAL-ELEMENT and INITIAL-CONTENTS should not be ~ 129 | specified")) 130 | (let ((vector (apply #'make-vector* nelts implementation 131 | :element-type element-type 132 | (when initial-element-p 133 | (list :initial-element initial-element))))) 134 | (when initial-contents 135 | (copy! initial-contents vector)) 136 | vector)) 137 | 138 | (defmethod implementation ((vector vecview)) 139 | (implementation (parent vector))) 140 | 141 | (defmethod element-type ((vector vecview)) 142 | (element-type (parent vector))) 143 | 144 | ;;;; *** Vector views 145 | 146 | (defgeneric slice-class (vector) 147 | (:documentation "Return the name of the class to be used for a slice 148 | of VECTOR.") 149 | (:method ((vector vector-like)) 'slice-vecview)) 150 | 151 | (defgeneric slice (vector &key offset stride nelts) 152 | (:documentation "Create a slice view of VECTOR.") 153 | (:method ((vector vector-like) 154 | &key (offset 0) (stride 1) (nelts (nelts vector))) 155 | (make-instance (slice-class vector) 156 | :parent vector 157 | :nelts nelts 158 | :offset offset 159 | :stride stride)) 160 | (:method ((vector slice-vecview) 161 | &key (offset 0) (stride 1) (nelts (nelts vector))) 162 | "For a slice on a slice-vecview, we can directly compute the slice 163 | parameters based on the parent of VECTOR." 164 | (make-instance (slice-class vector) 165 | :parent (parent vector) 166 | :nelts nelts 167 | :offset (+ offset (offset vector)) 168 | :stride (* stride (stride vector))))) 169 | 170 | ;;;; *** Specific vectors 171 | 172 | (defun vones (nelts &key 173 | (implementation *default-implementation*) 174 | (element-type *default-element-type*)) 175 | (make-vector nelts :implementation implementation 176 | :element-type element-type 177 | :initial-element (coerce 1 element-type))) 178 | 179 | (defun vzeros (nelts &key 180 | (implementation *default-implementation*) 181 | (element-type *default-element-type*)) 182 | (make-vector nelts :implementation implementation 183 | :element-type element-type 184 | :initial-element (coerce 0 element-type))) 185 | 186 | (defun vrand (nelts &key 187 | (implementation *default-implementation*) 188 | (element-type *default-element-type*) 189 | (state *random-state*)) 190 | ;; FIXME: doesn't work for complex types 191 | (check-type state random-state) 192 | (let ((vector (make-vector nelts :implementation implementation 193 | :element-type element-type)) 194 | (one (coerce 1 element-type))) 195 | (dotimes (i nelts) 196 | (setf (vref vector i) (random one state))) 197 | vector)) 198 | 199 | ;;;; ** Vector operations 200 | 201 | ;;;; *** Copying 202 | 203 | (defmethod copy! ((a vector-like) (b vector-like)) 204 | (assert (= (nelts a) (nelts b))) 205 | (assert (subtypep (element-type a) (element-type b))) 206 | (unless (eq a b) 207 | (dotimes (i (nelts a)) 208 | (setf (vref b i) (vref a i)))) 209 | b) 210 | 211 | (defmethod copy! ((a array) (b vector-like)) 212 | (unless (and (= (array-rank a) 1) 213 | (= (array-dimension a 0) (nelts b))) 214 | (error "A doesn't have the correct dimensions")) 215 | (let ((element-type (element-type b))) 216 | (dotimes (i (nelts b)) 217 | (assert (typep (aref a i) element-type)) 218 | (setf (vref b i) (aref a i)))) 219 | b) 220 | 221 | (defmethod copy! ((a list) (b vector-like)) 222 | (unless (= (nelts b) (length a)) 223 | (error "A doesn't have the correct dimensions")) 224 | (let ((element-type (element-type b))) 225 | (loop for i below (nelts b) for elt in a do 226 | (assert (typep elt element-type)) 227 | (setf (vref b i) elt))) 228 | b) 229 | 230 | (defmethod copy* ((vector vector-like) implementation) 231 | (make-vector (nelts vector) 232 | :implementation implementation 233 | :element-type (element-type vector) 234 | :initial-contents vector)) 235 | -------------------------------------------------------------------------------- /src/fortran/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile 2 | # Author: mfh 3 | # Date: 31 Dec 2006 4 | # Last modified: 31 Dec 2006 5 | # 6 | # Makefile for wrapper to libdl shared library functions. 7 | # Produces a shared library called "libshared". 8 | # 9 | # FIXME: Adjust this Makefile to fit your own system! 10 | # 11 | 12 | libshared.so: shared.c 13 | gcc -shared -ldl -o $@ $< 14 | -------------------------------------------------------------------------------- /src/fortran/fortran-mangling.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Author: mfh 2 | ;;;; Date: 30 Dec 2006 3 | ;;;; Last modified: 31 Dec 2006 4 | ;;;; 5 | ;;;; Package for figuring out the Fortran name mangling scheme used by 6 | ;;;; your linker for BLAS and LAPACK functions. 7 | ;;;; 8 | ;;;; GNU Autoconf has macros (e.g. AC_FC_FUNC) for determining how a 9 | ;;;; Fortran function name is mangled by the Fortran compiler. It's 10 | ;;;; interesting to note that Fortran names with underscores may be 11 | ;;;; mangled differently by some compilers than Fortran names without 12 | ;;;; underscores. 13 | ;;;; 14 | ;;;; We have chosen, however, not to invoke Autoconf to figure out the 15 | ;;;; mangling scheme, as it would create a dependency on the whole 16 | ;;;; Autoconf chain and the shell necessary for invoking it. Instead, 17 | ;;;; we observe that as of LAPACK 3.0, the BLAS and LAPACK Fortran 18 | ;;;; function names do not have underscores in them, so we can rely on 19 | ;;;; simple ad hoc tests based on known Fortran compilers. 20 | ;;;; 21 | ;;;; The SuperLU 3.0 source code, which was designed for maximum 22 | ;;;; compatibility on IBM AIX, Sun Solaris and GNU/Linux systems, 23 | ;;;; supports three different Fortran name mangling schemes: 24 | ;;;; 25 | ;;;; 1. No change (linker uses same name as in the Fortran source) 26 | ;;;; 2. Append one underscore (_) 27 | ;;;; 3. Change from lowercase to all uppercase 28 | ;;;; 29 | ;;;; If we test all combinations of these schemes as well as some 30 | ;;;; obvious similar schemes (e.g. prepend underscore, append two 31 | ;;;; underscores, change from uppercase to lowercase), we should cover 32 | ;;;; most reasonable Fortran name mangling schemes. Note that Fortran 33 | ;;;; 77 name mangling is much less annoying than C++ name mangling, 34 | ;;;; due to the lack of classes and namespaces. Fortran >= 90 name 35 | ;;;; mangling may be another story, but the BLAS and LAPACK (as of 36 | ;;;; LAPACK 3.0) have chosen not to use the "object-oriented" features 37 | ;;;; of Fortran >= 90 that may complicate name mangling. As we are 38 | ;;;; only interested in name mangling for the BLAS and LAPACK (we're 39 | ;;;; not writing a general Fortran name mangler), this should suffice 40 | ;;;; for our purposes. 41 | ;;;; 42 | ;;;; We explain in the comments below how CFFI is not sufficient for 43 | ;;;; our requirements; we include a C library which wraps the 44 | ;;;; necessary shared library functionality. The C library must be 45 | ;;;; compiled and built into a shared library. 46 | 47 | 48 | (in-package :lisp-matrix) 49 | 50 | 51 | ;;; Possible name mangling transformations. NOTE: not all of them are 52 | ;;; orthogonal: e.g. appending one underscore vs. appending two 53 | ;;; underscores. 54 | 55 | ;; string-upcase, string-downcase, string-capitalize 56 | 57 | ;;(asdf:oos 'asdf:load-op 'cffi) 58 | 59 | (defun prepend-one-underscore (s) 60 | (concatenate 'string "_" s)) 61 | (defun append-one-underscore (s) 62 | (concatenate 'string s "_")) 63 | (defun append-two-underscores (s) 64 | (concatenate 'string s "__")) 65 | 66 | 67 | ;;; FIXME: change the name of the shared libraries to suit your needs! 68 | ;; First open libdl 69 | (cffi:use-foreign-library "libdl.so") 70 | ;; Now open our custom library 71 | (cffi:use-foreign-library "./libshared.so") 72 | 73 | ;;; Shared library wrapper functions. 74 | (cffi:defcfun ("open_library" %open-library) :pointer 75 | (library-name :string)) 76 | (cffi:defcfun ("close_library" %close-library) :int 77 | (library :pointer)) 78 | (cffi:defcfun ("probe_library" %probe-library) :int 79 | (function-name :string) 80 | (library :pointer)) 81 | 82 | (defun probe-library (function-name library) 83 | (/= 0 (%probe-library function-name library))) 84 | 85 | (defmacro with-shared-library ((library library-name) &body body) 86 | "Opens the shared library named LIBRARY-NAME and binds a handle 87 | to it to the variable LIBRARY, then executes BODY. 88 | 89 | We don't use CFFI for the following reasons: 90 | 91 | 1. CFFI loads all objects into a common namespace, whereas 92 | we want a specific handle to a specific library. 93 | 2. CFFI doesn't currently handle closing libraries very well, 94 | as of 31 Dec 2006 (the CLOSE-FOREIGN-LIBRARY function is 95 | deliberately not exported). 96 | 97 | Instead of using CFFI, we call our own custom C functions. 98 | For POSIX-compliant systems, these are wrappers for the POSIX 99 | DL functions (dlopen, dlclose, dlsym). 100 | 101 | Because we aren't using CFFI, the only way to access the opened 102 | foreign library is via PROBE-LIBRARY or a wrapper function for 103 | DLSYM; the pointer returned by the latter can be used in 104 | FOREIGN-FUNCALL, if your CFFI and Lisp support FOREIGN-FUNCALL. 105 | " 106 | `(let ((,library nil)) 107 | (unwind-protect 108 | (progn 109 | (setf ,library (%open-library ,library-name)) 110 | (assert (not (cffi:null-pointer-p ,library))) 111 | ,@body) 112 | (if (and ,library (not (cffi:null-pointer-p ,library))) 113 | (%close-library ,library))))) 114 | 115 | (defun find-f77-mangling (function-name library-name) 116 | "Finds the Fortran 77 name mangling for the given function name, 117 | which is in the given shared library. Returns NIL if the mangling 118 | cannot be found." 119 | (let ((capitalizations '(identity string-upcase 120 | string-downcase string-capitalize)) 121 | (modifications '(identity prepend-one-underscore 122 | append-one-underscore append-two-underscores))) 123 | (with-shared-library (library library-name) 124 | (loop for capit in capitalizations do 125 | (loop for modif in modifications 126 | do 127 | (let ((mangled-name (funcall (symbol-function modif) 128 | (funcall (symbol-function capit) 129 | function-name)))) 130 | (when (probe-library mangled-name library) 131 | (return (list capit modif))))))))) 132 | 133 | (defun get-f77-mangling-function (test-function-name library-name) 134 | (let ((pair (find-f77-mangling test-function-name library-name))) 135 | (if (null pair) 136 | (error "Failed to determine F77 name mangling function") 137 | (destructuring-bind (capit modif) pair 138 | #'(lambda (s) (funcall (symbol-function modif) 139 | (funcall (symbol-function capit) 140 | s))))))) 141 | -------------------------------------------------------------------------------- /src/fortran/shared.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include /* #defines NULL */ 3 | 4 | void* 5 | open_library (char* library_name) 6 | { 7 | return dlopen (library_name, RTLD_LAZY); 8 | } 9 | 10 | /** 11 | * Returns zero on success, nonzero on error. 12 | */ 13 | int 14 | close_library (void* lib) 15 | { 16 | return dlclose (lib); 17 | } 18 | 19 | int 20 | probe_library (char* function_name, char* library_name) 21 | { 22 | void* lib = open_library (library_name); 23 | if (lib == NULL) 24 | return 0; 25 | else 26 | { 27 | void* fun = dlsym (lib, function_name); 28 | close_library (lib); 29 | return fun != NULL; 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /src/lapack-cholesky.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-matrix) 2 | 3 | ;;; CHOLESKY 4 | 5 | ;;; POTRF - compute the Cholesky Factorization of a real sym pos-def 6 | ;;; matrix A. 7 | ;;; Returns Matrix, upper/lower triang char, info 8 | (def-lapack-method potrf ((a !matrix-type)) 9 | (assert (<= (ncols a) (nrows a))) ; LAPACK condition, kill in lisp 10 | ; not fortran. 11 | (let ((info (make-fnv-int32 1 :initial-value 0))) 12 | (with-copies ((a (or (not unit-strides-p) 13 | transposed-p))) 14 | (list a 15 | "U" 16 | (check-info (fnv-int32-ref info 0) "POTRF")) 17 | (!function "U" ; store in Upper Triang. Option for "L"? 18 | (ncols a) ; N 19 | a ; matrix (in/out) 20 | (real-nrows a) ; LDA 21 | info)))) ; info 22 | 23 | #| 24 | 25 | DPOTRF(3) DPOTRF(3) 26 | 27 | NAME DPOTRF - compute the Cholesky factorization of a real symmetric positive definite 28 | matrix A 29 | 30 | SYNOPSIS 31 | SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) 32 | 33 | CHARACTER UPLO 34 | INTEGER INFO, LDA, N 35 | DOUBLE PRECISION A( LDA, * ) 36 | 37 | PURPOSE 38 | DPOTRF computes the Cholesky factorization of a real symmetric positive definite 39 | matrix A. The factorization has the form 40 | A = U**T * U, if UPLO = ’U’, or 41 | A = L * L**T, if UPLO = ’L’, 42 | where U is an upper triangular matrix and L is lower triangular. 43 | 44 | This is the block version of the algorithm, calling Level 3 BLAS. 45 | 46 | ARGUMENTS 47 | UPLO (input) CHARACTER*1 48 | = ’U’: Upper triangle of A is stored; 49 | = ’L’: Lower triangle of A is stored. 50 | N (input) INTEGER 51 | The order of the matrix A. N >= 0. 52 | A (input/output) DOUBLE PRECISION array, dimension (LDA,N) 53 | On entry, the symmetric matrix A. If UPLO = ’U’, the leading N-by-N upper 54 | triangular part of A contains the upper triangular part of the matrix A, and 55 | the strictly lower triangular part of A is not referenced. If UPLO = ’L’, 56 | the leading N-by-N lower triangular part of A contains the lower triangular 57 | part of the matrix A, and the strictly upper triangular part of A is not 58 | referenced. 59 | On exit, if INFO = 0, the factor U or L from the Cholesky factorization A = 60 | U**T*U or A = L*L**T. 61 | LDA (input) INTEGER 62 | The leading dimension of the array A. LDA >= max(1,N). 63 | INFO (output) INTEGER 64 | = 0: successful exit 65 | < 0: if INFO = -i, the i-th argument had an illegal value 66 | > 0: if INFO = i, the leading minor of order i is not positive definite, 67 | and the factorization could not be completed. 68 | 69 | LAPACK version 3.0 15 June 2000 DPOTRF(3) 70 | 71 | |# 72 | 73 | 74 | 75 | 76 | ;;; CHOLESKY 77 | ;; 78 | ;; POTRI - compute the inverse of a real symmetric positive definite 79 | ;; matrix A using the Cholesky factorization A = U**T*U or A = L*L**T 80 | (def-lapack-method potri ((a !matrix-type)) 81 | (assert (= (ncols a) (nrows a))) ; only square matrices 82 | (let ((info (make-fnv-int32 1 :initial-value 0))) 83 | (with-copies ((a (or (not unit-strides-p) 84 | transposed-p) 85 | t)) 86 | ;; Returning: 87 | ;; - inverse, 88 | ;; - "U" since upper format trangular, 89 | ;; - info, for correctness of results. 90 | ;; Should we put INFO first?! 91 | (list a 92 | "U" ; not useful until we add option for lowercase. 93 | (check-info (fnv-int32-ref info 0) "POTRI")) 94 | (!function "U" ; "L" (in) is lower an option? 95 | (ncols a) ; N (in) (order of matrix, columns, 2nd index 96 | a ; a (in/out) matrix 97 | (nrows a) ; LDA (in) leading dimension, LDA >= max(1,N) 98 | ; above was "(real-nrows a)" ? 99 | info)))) ; info (out) 100 | 101 | 102 | (def-lapack-method potrs ((a !matrix-type) (b !matrix-type) ipiv-a) 103 | (assert (<= (ncols a) (nrows a))) ; make sure A supports options 104 | (let ((uplo "U") 105 | (info (make-fnv-int32 1 :initial-value 0))) 106 | (with-copies ((a (or (not unit-strides-p) 107 | transposed-p)) 108 | (b (or (not unit-strides-p) 109 | transposed-p))) 110 | (list b 111 | (check-info (fnv-int32-ref info 0) "POTRS")) 112 | (!function uplo ; matrix orientation, None, Transpose, Adjoint 113 | (ncols a) ; N 114 | (ncols b) ; NHRS 115 | a ; A 116 | (nrows a) ; LDA 117 | b ; B 118 | (nrows b) ; LDB 119 | info)))) ; info 120 | 121 | #| 122 | NAME DPOTRS - solve a system of linear equations A*X = B with a symmetric positive defi‐ 123 | nite matrix A using the Cholesky factorization A = U**T*U or A = L*L**T computed by 124 | DPOTRF 125 | 126 | SYNOPSIS 127 | SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) 128 | 129 | CHARACTER UPLO 130 | INTEGER INFO, LDA, LDB, N, NRHS 131 | DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 132 | 133 | PURPOSE 134 | DPOTRS solves a system of linear equations A*X = B with a symmetric positive defi‐ 135 | nite matrix A using the Cholesky factorization A = U**T*U or A = L*L**T computed by 136 | DPOTRF. 137 | 138 | ARGUMENTS 139 | UPLO (input) CHARACTER*1 140 | = ’U’: Upper triangle of A is stored; 141 | = ’L’: Lower triangle of A is stored. 142 | N (input) INTEGER 143 | The order of the matrix A. N >= 0. 144 | NRHS (input) INTEGER 145 | The number of right hand sides, i.e., the number of columns of the matrix B. 146 | NRHS >= 0. 147 | A (input) DOUBLE PRECISION array, dimension (LDA,N) 148 | The triangular factor U or L from the Cholesky factorization A = U**T*U or A 149 | = L*L**T, as computed by DPOTRF. 150 | LDA (input) INTEGER 151 | The leading dimension of the array A. LDA >= max(1,N). 152 | B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) 153 | On entry, the right hand side matrix B. On exit, the solution matrix X. 154 | LDB (input) INTEGER 155 | The leading dimension of the array B. LDB >= max(1,N). 156 | INFO (output) INTEGER 157 | = 0: successful exit 158 | < 0: if INFO = -i, the i-th argument had an illegal value 159 | |# 160 | 161 | (defun minv-cholesky (a) 162 | "invert A using LU Factorization. A must be symmetric." 163 | (check-type a matrix-like) 164 | (assert (matrix-like-symmetric-p a)) 165 | (assert (= (nrows a) (ncols a))) 166 | (let ((a-fac (first (potrf (copy a))))) 167 | (trap2mat (first (potri a-fac))))) 168 | 169 | #+nil(progn 170 | (let* ((m1 (rand 3 3)) 171 | (m1tm1 (m* (transpose m1) m1))) 172 | (m* m1tm1 (minv-cholesky m1tm1)))) 173 | 174 | (defun msolve-cholesky (a b) 175 | "Compute `x1' solving `A x = b', with LU factorization." 176 | (let ((a-fac (potrf (copy a)))) 177 | (first (potrs (first a-fac) b (second a-fac))))) 178 | 179 | #+nil (progn 180 | (let* ((a (rand 3 3)) 181 | (x-pre (rand 3 1)) 182 | (b (m* a x-pre))) 183 | (m- x-pre (msolve-cholesky a b)))) 184 | -------------------------------------------------------------------------------- /src/lapack-ls.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-matrix) 2 | 3 | ;;; Least Squares (in the generalized sense) solvers. 4 | ;;; by that, including LS, WLS, and GLS. 5 | 6 | ;;; Solving ax = b 7 | ;;; note that 'a' will be modified upon the call, and will have a 8 | ;;; different value at the end, more appropriate to the transformation 9 | ;;; (i.e. will be the QR, but stored in common compact form). 10 | 11 | (def-lapack-method (gelsy :function-names 12 | ((%sgelsy single-float single-float) 13 | (%dgelsy double-float double-float))) 14 | ((a !matrix-type) 15 | (b !matrix-type) 16 | rcond &optional jpvt) 17 | ;; FIXME: has both LWORK and RWORK for %ZGELSY and %CGELSY 18 | ;; so need to handle those via explicit methods 19 | (unless jpvt 20 | (setq jpvt (make-fnv-int32 (ncols a) :initial-value 0))) 21 | (let ((rank (make-fnv-int32 1 :initial-value 0)) 22 | (info (make-fnv-int32 1 :initial-value 0))) 23 | ;; FIXME: B needs to be resized anyway if A has more columns than 24 | ;; rows, to allow for enough storage for the result matrix => 25 | ;; quick fix: disallow this 26 | (assert (<= (ncols a) (nrows a))) 27 | (with-copies ((a (or (not unit-strides-p) 28 | transposed-p)) 29 | (b (or (not unit-strides-p) 30 | transposed-p) 31 | t)) 32 | ;; FIXME: the value RANK is not correct because the cffi type 33 | ;; :FORTRAN-INT does not define a TRANSLATE-FROM-FOREIGN method? 34 | ;; => why not use a standard cffi integer type anyway?? 35 | ;; (a fix is to make RANK a fnv-int32 with one element 36 | (progn 37 | (check-info (fnv-int32-ref info 0) "GELSY") 38 | (list (if (= (nrows b) (ncols a)) ; returns (list b rank) 39 | b 40 | (window b :nrows (ncols a))) 41 | (fnv-int32-ref rank 0))) 42 | (call-with-work (lwork work !data-type) 43 | (!function (nrows a) ; M 44 | (ncols a) ; N 45 | (ncols b) ; NRHS 46 | a ; A 47 | (real-nrows a) ; LDA 48 | b ; B 49 | (real-nrows b) ; LDB 50 | jpvt ; JPVT 51 | rcond ; RCOND 52 | rank ; RANK 53 | (data work) ; WORK 54 | lwork ; LWORK 55 | info))))) ; INFO 56 | 57 | #| 58 | NAME DGELSY - compute the minimum-norm solution to a real linear 59 | least squares problem 60 | 61 | SYNOPSIS 62 | SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, 63 | RANK, WORK, LWORK, INFO ) 64 | 65 | INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK 66 | DOUBLE PRECISION RCOND 67 | INTEGER JPVT( * ) 68 | DOUBLE PRECISION A( LDA, * ), B( LDB, *), WORK(*) 69 | PURPOSE 70 | 71 | DGELSY computes the minimum-norm solution to a real linear 72 | least squares problem: 73 | 74 | minimize || A * X - B || 75 | 76 | using a complete orthogonal factorization of A. A is an M-by-N 77 | matrix which may be rank-deficient. 78 | 79 | Several right hand side vectors b and solution vectors x can be 80 | handled in a single call; they are stored as the columns of the 81 | M-by-NRHS right hand side matrix B and the N-by-NRHS solution 82 | matrix X. 83 | 84 | The routine first computes a QR factorization with column 85 | pivoting: 86 | 87 | A * P = Q * [ R11 R12 ] 88 | [ 0 R22 ] 89 | 90 | with R11 defined as the largest leading submatrix whose 91 | estimated condition number is less than 1/RCOND. The order of 92 | R11, RANK, is the effective rank of A. 93 | 94 | Then, R22 is considered to be negligible, and R12 is 95 | annihilated by orthogonal transformations from the right, 96 | arriving at the complete orthogonal factorization: 97 | 98 | A * P = Q * [ T11 0 ] * Z 99 | [ 0 0 ] 100 | The minimum-norm solution is then 101 | 102 | X = P * Z’ [ inv(T11)*Q1’*B ] 103 | [ 0 ] 104 | where Q1 consists of the first RANK columns of Q. 105 | 106 | This routine is basically identical to the original xGELSX 107 | except three differences: 108 | 109 | o The call to the subroutine xGEQPF has been substituted by 110 | the the call to the subroutine xGEQP3. This subroutine is 111 | a Blas-3 version of the QR factorization with column 112 | pivoting. 113 | o Matrix B (the right hand side) is updated with Blas-3. 114 | o The permutation of matrix B (the right hand side) is faster 115 | and more simple. 116 | 117 | ARGUMENTS 118 | M (input) INTEGER 119 | The number of rows of the matrix A. M >= 0. 120 | 121 | N (input) INTEGER 122 | The number of columns of the matrix A. N >= 0. 123 | 124 | NRHS (input) INTEGER 125 | The number of right hand sides, i.e., the number of 126 | columns of matrices B and X. NRHS >= 0. 127 | 128 | A (input/output) DOUBLE PRECISION array, dimension 129 | (LDA,N) On entry, the M-by-N matrix A. On exit, A has 130 | been overwritten by details of its complete orthogonal 131 | factorization. 132 | 133 | LDA (input) INTEGER 134 | The leading dimension of the array A. LDA >= max(1,M). 135 | 136 | B (input/output) DOUBLE PRECISION array, 137 | dimension (LDB,NRHS) On entry, the M-by-NRHS right hand 138 | side matrix B. On exit, the N-by-NRHS solution matrix 139 | X. 140 | 141 | LDB (input) INTEGER 142 | The leading dimension of the array B. LDB >= 143 | max(1,M,N). 144 | 145 | JPVT (input/output) INTEGER array, dimension (N) 146 | On entry, if JPVT(i) .ne. 0, the i-th column of A is 147 | permuted to the front of AP, otherwise column i is a 148 | free column. On exit, if JPVT(i) = k, then the i-th 149 | column of AP was the k-th column of A. 150 | 151 | RCOND (input) DOUBLE PRECISION 152 | RCOND is used to determine the effective rank of A, 153 | which is defined as the order of the largest leading 154 | triangular submatrix R11 in the QR factorization with 155 | pivoting of A, whose estimated condition number < 156 | 1/RCOND. 157 | 158 | RANK (output) INTEGER 159 | The effective rank of A, i.e., the order of the subma‐ 160 | trix R11. This is the same as the order of the subma‐ 161 | trix T11 in the complete orthogonal factorization of A. 162 | 163 | WORK (workspace/output) DOUBLE PRECISION array, dimension 164 | (LWORK) 165 | On exit, if INFO = 0, WORK(1) returns the optimal 166 | LWORK. 167 | 168 | LWORK (input) INTEGER 169 | The dimension of the array WORK. The unblocked strat‐ 170 | egy requires that: LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ), 171 | where MN = min( M, N ). The block algorithm requires 172 | that: LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ), 173 | where NB is an upper bound on the blocksize returned by 174 | ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR, 175 | and DORMRZ. 176 | 177 | If LWORK = -1, then a workspace query is assumed; the 178 | routine only calculates the optimal size of the WORK 179 | array, returns this value as the first entry of the 180 | WORK array, and no error message related to LWORK is 181 | issued by XERBLA. 182 | 183 | INFO (output) INTEGER 184 | = 0: successful exit 185 | < 0: If INFO = -i, the i-th argument had an illegal 186 | value. 187 | 188 | FURTHER DETAILS 189 | Based on contributions by 190 | A. Petitet, Computer Science Dept., Univ. of Tenn., 191 | Knoxville, USA 192 | E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, 193 | Spain 194 | G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, 195 | Spain 196 | 197 | LAPACK version 3.0 15 June 2000 DGELSY(3) 198 | |# 199 | 200 | #+nil 201 | (progn 202 | (let ((*default-implementation* :foreign-array)) 203 | (let* ((m 10) 204 | (n 10) 205 | (a (rand m n)) 206 | (x (rand n 1)) 207 | (b (m* a x)) 208 | (rcond (* (coerce (expt 2 -52) 'double-float) 209 | (max (nrows a) (ncols a)))) 210 | (orig-a (copy a)) 211 | (orig-b (copy b)) 212 | (orig-x (copy x))) 213 | (list x (gelsy a b rcond))))) 214 | 215 | #+nil 216 | (setf *temp-result* 217 | (let ((*default-implementation* :lisp-array)) 218 | (let* ((m 10) 219 | (n 10) 220 | (a (rand m n)) 221 | (x (rand n 1)) 222 | (b (m* a x)) 223 | (rcond (* (coerce (expt 2 -52) 'double-float) 224 | (max (nrows a) (ncols a)))) 225 | (orig-a (copy a)) 226 | (orig-b (copy b)) 227 | (orig-x (copy x))) 228 | (list x (gelsy a b rcond))))) 229 | 230 | 231 | 232 | #+nil 233 | (progn 234 | ;; consider Y = X b (or normal approach, X b = Y) 235 | (defparameter *gelsy-result* 236 | (let* ((n 10) 237 | (p 5) 238 | (x-temp (rand n p)) 239 | (b-temp (rand p 1)) 240 | (y-temp (m* x-temp b-temp)) ;; so Y=Xb 241 | (rcond (* (coerce (expt 2 -52) 'double-float) 242 | (max (nrows x-temp) (ncols y-temp))))) 243 | ;; should be numerically 0 244 | (v- b-temp (first (gelsy x-temp y-temp rcond))))) 245 | 246 | (princ *gelsy-result*) ) 247 | 248 | 249 | (defun least-squares-gelsy (x y) 250 | "Solves: 251 | X beta = Y, 252 | for beta." 253 | (list x (gelsy x y 254 | (* (coerce (expt 2 -52) 'double-float) 255 | (max (nrows x) (ncols x)))))) 256 | -------------------------------------------------------------------------------- /src/lapack-lu.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-matrix) 2 | 3 | ;;; LU-decomp tools 4 | 5 | ;;; Need: tests 6 | 7 | ;;; GETRF - compute the LU Factorization of a matrix. 8 | ;;; Returns Matrix, upper/lower triang char, info 9 | #| 10 | 11 | DGETRF(3) ) DGETRF(3) 12 | 13 | NAME DGETRF - compute an LU factorization of a general M-by-N matrix A using partial piv‐ 14 | oting with row interchanges 15 | 16 | SYNOPSIS 17 | SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) 18 | INTEGER INFO, LDA, M, N 19 | INTEGER IPIV( * ) 20 | DOUBLE PRECISION A( LDA, * ) 21 | 22 | PURPOSE 23 | DGETRF computes an LU factorization of a general M-by-N matrix A using partial piv‐ 24 | oting with row interchanges. The factorization has the form 25 | A = P * L * U 26 | where P is a permutation matrix, L is lower triangular with unit diagonal elements 27 | (lower trapezoidal if m > n), and U is upper triangular (upper trapezoidal if m < 28 | n). 29 | 30 | This is the right-looking Level 3 BLAS version of the algorithm. 31 | 32 | ARGUMENTS 33 | M (input) INTEGER 34 | The number of rows of the matrix A. M >= 0. 35 | 36 | N (input) INTEGER 37 | The number of columns of the matrix A. N >= 0. 38 | 39 | A (input/output) DOUBLE PRECISION array, dimension (LDA,N) 40 | On entry, the M-by-N matrix to be factored. On exit, the factors L and U 41 | from the factorization A = P*L*U; the unit diagonal elements of L are not 42 | stored. 43 | 44 | LDA (input) INTEGER 45 | The leading dimension of the array A. LDA >= max(1,M). 46 | 47 | IPIV (output) INTEGER array, dimension (min(M,N)) 48 | The pivot indices; for 1 <= i <= min(M,N), row i of the matrix was inter‐ 49 | changed with row IPIV(i). 50 | 51 | INFO (output) INTEGER 52 | = 0: successful exit 53 | < 0: if INFO = -i, the i-th argument had an illegal value 54 | > 0: if INFO = i, U(i,i) is exactly zero. The factorization has been com‐ 55 | pleted, but the factor U is exactly singular, and division by zero will 56 | occur if it is used to solve a system of equations. 57 | 58 | LAPACK version 3.0 15 June 2000 DGETRF(3) 59 | |# 60 | 61 | (def-lapack-method getrf ((a !matrix-type) &optional ipiv) 62 | (assert (<= (ncols a) (nrows a))) ; A must be NxM, N>=M 63 | (let ((info (make-fnv-int32 1 :initial-value 0)) 64 | (ipiv-local (if ipiv 65 | ipiv 66 | ;; make it the bigger of # cols/ # rows 67 | (make-fnv-int32 (max (nrows a) (ncols a)) 68 | :initial-value 0)))) 69 | (with-copies ((a (or (not unit-strides-p) 70 | transposed-p))) 71 | (list a ; compact PLU form. 72 | ipiv-local 73 | (check-info (fnv-int32-ref info 0) "GETRF")) 74 | (!function (nrows a) ; M in 75 | (ncols a) ; N in 76 | a ; A in/out 77 | (max 1 (ncols a)); LDA in 78 | ;; IPIV (output) INTEGER array, dimension (min(M,N)) 79 | ;; The pivot indices; for 1 <= i <= min(M,N), row i of 80 | ;; the matrix was interchanged with row IPIV(i) 81 | ipiv-local ; OUT 82 | info)))); info 83 | 84 | ;;;;;;;;;;;; 85 | 86 | ;;; GETRI - invert a matrix using LU factorization. 87 | ;;; Returns Matrix, upper/lower triang char, info 88 | (def-lapack-method getri ((a !matrix-type) ipiv) 89 | (assert (<= (ncols a) (nrows a))) ; make sure A supports options 90 | (let ((info (make-fnv-int32 1 :initial-value 0)) 91 | (ipiv-local (if ipiv 92 | ipiv 93 | ;; make it the bigger of # cols/ # rows 94 | (make-fnv-int32 (max (nrows a) (ncols a)) 95 | :initial-value 0)))) 96 | (with-copies ((a (or (not unit-strides-p) 97 | transposed-p) 98 | t)) 99 | (list a 100 | ipiv-local 101 | (check-info (fnv-int32-ref info 0) "GETRF")) 102 | 103 | 104 | (call-with-work (lwork work !data-type) 105 | (!function (ncols a) ; M 106 | a ; A 107 | (nrows a) ; N 108 | ipiv ; from getrf result 109 | work ; array for comp 110 | lwork ; dimension of work 111 | info))))); info 112 | 113 | #| 114 | DGETRI(3) ) DGETRI(3) 115 | 116 | NAME DGETRI - compute the inverse of a matrix using the LU factorization 117 | computed by DGETRF 118 | 119 | SYNOPSIS 120 | SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) 121 | 122 | INTEGER INFO, LDA, LWORK, N 123 | INTEGER IPIV( * ) 124 | DOUBLE PRECISION A( LDA, * ), WORK( * ) 125 | 126 | PURPOSE 127 | DGETRI computes the inverse of a matrix using the LU factorization com‐ 128 | puted by DGETRF. This method inverts U and then computes inv(A) by 129 | solving the system inv(A)*L = inv(U) for inv(A). 130 | 131 | ARGUMENTS 132 | N (input) INTEGER 133 | The order of the matrix A. N >= 0. 134 | 135 | A (input/output) DOUBLE PRECISION array, dimension (LDA,N) 136 | On entry, the factors L and U from the factorization A = P*L*U 137 | as computed by DGETRF. On exit, if INFO = 0, the inverse of 138 | the original matrix A. 139 | 140 | LDA (input) INTEGER 141 | The leading dimension of the array A. LDA >= max(1,N). 142 | 143 | IPIV (input) INTEGER array, dimension (N) 144 | The pivot indices from DGETRF; for 1<=i<=N, row i of the matrix 145 | was interchanged with row IPIV(i). 146 | 147 | WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) 148 | On exit, if INFO=0, then WORK(1) returns the optimal LWORK. 149 | 150 | LWORK (input) INTEGER 151 | The dimension of the array WORK. LWORK >= max(1,N). For opti‐ 152 | mal performance LWORK >= N*NB, where NB is the optimal block‐ 153 | size returned by ILAENV. 154 | 155 | If LWORK = -1, then a workspace query is assumed; the routine 156 | only calculates the optimal size of the WORK array, returns 157 | this value as the first entry of the WORK array, and no error 158 | message related to LWORK is issued by XERBLA. 159 | 160 | INFO (output) INTEGER 161 | = 0: successful exit 162 | < 0: if INFO = -i, the i-th argument had an illegal value 163 | > 0: if INFO = i, U(i,i) is exactly zero; the matrix is singu‐ 164 | lar and its inverse could not be computed. 165 | 166 | LAPACK version 3.0 15 June 2000 DGETRI(3) 167 | |# 168 | 169 | 170 | 171 | 172 | ;;; GETRS - Solve Ax=b using LU factorization. 173 | ;;; Returns Matrix, upper/lower triang char, info 174 | (def-lapack-method getrs ((a !matrix-type) (b !matrix-type) ipiv-a) 175 | (assert (<= (ncols a) (nrows a))) ; make sure A supports options 176 | (let ((trans "N") 177 | (info (make-fnv-int32 1 :initial-value 0))) 178 | (with-copies ((a (or (not unit-strides-p) 179 | transposed-p)) 180 | (b (or (not unit-strides-p) 181 | transposed-p))) 182 | (list b 183 | (check-info (fnv-int32-ref info 0) "GETRS")) 184 | (!function trans ; matrix orientation, None, Transpose, Adjoint 185 | (ncols a) ; N 186 | (ncols b) ; NHRS 187 | a ; A 188 | (nrows a) ; LDA 189 | ipiv-a ; from getrf result 190 | b ; B 191 | (nrows b) ; LDB 192 | info)))) ; info 193 | #| 194 | DGETRS(3) ) DGETRS(3) 195 | 196 | NAME DGETRS - solve a system of linear equations A * X = B or A’ * X = B with a general 197 | N-by-N matrix A using the LU factorization computed by DGETRF 198 | 199 | SYNOPSIS 200 | SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 201 | 202 | CHARACTER TRANS 203 | INTEGER INFO, LDA, LDB, N, NRHS 204 | INTEGER IPIV( * ) 205 | DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 206 | 207 | PURPOSE 208 | DGETRS solves a system of linear equations A * X = B or A’ * X = B with a general N- 209 | by-N matrix A using the LU factorization computed by DGETRF. 210 | 211 | ARGUMENTS 212 | TRANS (input) CHARACTER*1 213 | Specifies the form of the system of equations: 214 | = ’N’: A * X = B (No transpose) 215 | = ’T’: A’* X = B (Transpose) 216 | = ’C’: A’* X = B (Conjugate transpose = Transpose) 217 | N (input) INTEGER 218 | The order of the matrix A. N >= 0. 219 | NRHS (input) INTEGER 220 | The number of right hand sides, i.e., the number of columns of the matrix B. 221 | NRHS >= 0. 222 | A (input) DOUBLE PRECISION array, dimension (LDA,N) 223 | The factors L and U from the factorization A = P*L*U as computed by DGETRF. 224 | LDA (input) INTEGER 225 | The leading dimension of the array A. LDA >= max(1,N). 226 | IPIV (input) INTEGER array, dimension (N) 227 | The pivot indices from DGETRF; for 1<=i<=N, row i of the matrix was inter‐ 228 | changed with row IPIV(i). 229 | B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) 230 | On entry, the right hand side matrix B. On exit, the solution matrix X. 231 | LDB (input) INTEGER 232 | The leading dimension of the array B. LDB >= max(1,N). 233 | INFO (output) INTEGER 234 | = 0: successful exit 235 | < 0: if INFO = -i, the i-th argument had an illegal value 236 | 237 | LAPACK version 3.0 15 June 2000 DGETRS(3) 238 | 239 | |# 240 | 241 | 242 | 243 | ;;; LU common applications 244 | 245 | (defun minv-lu (a) 246 | "invert A using LU Factorization" 247 | (let ((a-fac (getrf (copy a)))) 248 | (first (getri (first a-fac) (second a-fac))))) 249 | 250 | #+nil (progn 251 | (let ((m1 (rand 3 3))) 252 | (m* m1 (minv-lu m1)))) 253 | 254 | (defun msolve-lu (a b) 255 | "Compute `x1' solving `A x = b', with LU factorization." 256 | (let ((a-fac (getrf (copy a)))) 257 | (first (getrs (first a-fac) b (second a-fac))))) 258 | 259 | #+nil (progn 260 | (let* ((a (rand 3 3)) 261 | (x-pre (rand 3 1)) 262 | (b (m* a x-pre))) 263 | (m- x-pre (msolve-lu a b)))) 264 | -------------------------------------------------------------------------------- /src/lapack-methods.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp -*- 2 | 3 | ;;; Time-stamp: <2009-06-24 07:52:25 tony> 4 | ;;; Creation: <2009-02-05 11:18:51 tony> 5 | ;;; File: lapack-methods.lisp 6 | ;;; Author: Mark H. < @ > 7 | ;;; Maintainer: AJ Rossini 8 | ;;; Copyright: (c)2009--, AJ Rossini. BSD, LLGPL, or GPLv2, depending 9 | ;;; on how it arrives. 10 | ;;; Purpose: Invocation across storage types (local/foreign; precision 11 | ;;; / real/complex) 12 | 13 | ;;; What is this talk of 'release'? Klingons do not make software 14 | ;;; 'releases'. Our software 'escapes', leaving a bloody trail of 15 | ;;; designers and quality assurance people in its wake. 16 | 17 | (in-package :lisp-matrix) 18 | 19 | ;;; This file contains actual BLAS/LAPACK method invocation from Lisp. 20 | ;;; See functions in lapack-utils.lisp for how supporting utility 21 | ;;; macros and functions work. 22 | 23 | ;;; * Blas methods 24 | ;;; 25 | ;;; ** Level 1 BLAS 26 | ;;; 27 | ;;; Done: xSCAL, xAXPY, xDOT xDOTU, xDOTC, 28 | ;;; 29 | ;;; Miss some names: xNRM2, xASUM, IxAMAX 30 | ;;; FIXME (AJR): these look to be done? What does the above mean?? 31 | ;;; 32 | ;;; TODO: xROTG, xROTMG, xROT, xROTM, xSWAP, xCOPY, xSDOT 33 | 34 | (def-lapack-method scal (alpha (x !matrix-type)) 35 | (assert (typep alpha '!element-type)) 36 | (with-copies ((x (or (not unit-strides-p) 37 | (not zero-offset-p)) 38 | t)) 39 | x 40 | (!function (nelts x) alpha x 1))) 41 | 42 | ;; FIXME: needed so to harmonize vectors with matrix cases 43 | (defmethod scal (alpha (x la-vector-double)) 44 | (assert (typep alpha 'double-float)) 45 | (with-copies ((x (not real-stride) t)) 46 | x 47 | (%dscal (nelts x) alpha x (real-stride x)))) 48 | 49 | #+nil 50 | (let ((x (ones 5 5))) 51 | (time 52 | (progn 53 | (scal 2d0 (row x 1)) 54 | (scal 3d0 (col x 3)) 55 | x))) 56 | 57 | (def-lapack-method axpy (alpha (x !matrix-type) (y !matrix-type)) 58 | (assert (typep alpha '!element-type)) 59 | (assert (= (nelts x) (nelts y))) 60 | (with-copies ((x (or (not unit-strides-p) 61 | (not zero-offset-p))) 62 | (y (or (not unit-strides-p) 63 | (not zero-offset-p)) 64 | t)) 65 | y 66 | (!function (nelts x) alpha x 1 y 1))) 67 | 68 | (def-lapack-method dot ((x !matrix-type) (y !matrix-type)) 69 | (assert (= (nelts x) (nelts y))) 70 | (with-copies ((x (or (not unit-strides-p) 71 | (not zero-offset-p))) 72 | (y (or (not unit-strides-p) 73 | (not zero-offset-p)))) 74 | nil 75 | (!function (nelts x) x 1 y 1))) 76 | 77 | (def-lapack-method dotu ((x !matrix-type) (y !matrix-type)) 78 | (assert (= (nelts x) (nelts y))) 79 | (with-copies ((x (or (not unit-strides-p) 80 | (not zero-offset-p))) 81 | (y (or (not unit-strides-p) 82 | (not zero-offset-p)))) 83 | nil 84 | (!function (nelts x) x 1 y 1))) 85 | 86 | (def-lapack-method dotc ((x !matrix-type) (y !matrix-type)) 87 | (assert (= (nelts x) (nelts y))) 88 | (with-copies ((x (or (not unit-strides-p) 89 | (not zero-offset-p))) 90 | (y (or (not unit-strides-p) 91 | (not zero-offset-p)))) 92 | nil 93 | (!function (nelts x) x 1 y 1))) 94 | 95 | (def-lapack-method (nrm2 :function-names 96 | ((%snrm2 single-float) 97 | (%dnrm2 double-float) 98 | (%scnrm2 (complex single-float)) 99 | (%dznrm2 (complex double-float)))) 100 | ((x !matrix-type)) 101 | (with-copies ((x (or (not unit-strides-p) 102 | (not zero-offset-p)))) 103 | nil 104 | (!function (nelts x) x 1))) 105 | 106 | (def-lapack-method (asum :function-names 107 | ((%sasum single-float) 108 | (%dasum double-float) 109 | (%scasum (complex single-float)) 110 | (%dzasum (complex double-float)))) 111 | ((x !matrix-type)) 112 | (with-copies ((x (or (not unit-strides-p) 113 | (not zero-offset-p)))) 114 | nil 115 | (!function (nelts x) x 1))) 116 | 117 | (def-lapack-method (iamax :function-names 118 | ((%isamax single-float) 119 | (%idamax double-float) 120 | (%icamax (complex single-float)) 121 | (%izamax (complex double-float)))) 122 | ((x !matrix-type)) 123 | (with-copies ((x (or (not unit-strides-p) 124 | (not zero-offset-p)))) 125 | nil 126 | ;; LAPACK element numbering starts from 1, so we correct this to 127 | ;; the lisp style starting from 0. 128 | (1- (!function (nelts x) x 1)))) 129 | 130 | ;;; ** Level 2 BLAS 131 | ;;; 132 | ;;; Done: none 133 | ;;; 134 | ;;; To do: xGEMV, xGBMV, xHBMV, xHPMV, xSYMV, xSBMV, xSPMV, xTRMV, 135 | ;;; xTBMV, xTPMV, xTRSV, xTBSV, xTPSV, xGER, xGERU, xGERC, xHER, 136 | ;;; xHPR, xHER2, xHPR2, xSYR, xSPR, xSYR2, xSPR2 137 | ;;; 138 | ;;; ** Extended precision Level 2 BLAS 139 | ;;; 140 | ;;; Done: 141 | ;;; 142 | ;;; To do: 143 | ;;; 144 | ;;; ** LEVEL 3 BLAS 145 | ;;; 146 | ;;; Done: xGEMM 147 | ;;; 148 | ;;; To do: xSYMM, xHEMM, xSYRK, xHERK, xSYR2K, xHER2K, xTRMM, xTRSM, 149 | 150 | (def-lapack-method gemm (alpha 151 | (a !matrix-type) 152 | (b !matrix-type) 153 | beta 154 | (c !matrix-type)) 155 | (assert (= (ncols a) (nrows b))) 156 | (assert (= (nrows a) (nrows c))) 157 | (assert (= (ncols b) (ncols c))) 158 | (with-copies ((a (or (not unit-strides-p))) 159 | (b (or (not unit-strides-p))) 160 | (c (or (not unit-strides-p) 161 | transposed-p) 162 | t)) 163 | c 164 | (!function (orientation-letter a) 165 | (orientation-letter b) 166 | (nrows a) 167 | (ncols b) 168 | (ncols a) 169 | alpha 170 | a 171 | (real-nrows a) 172 | b 173 | (real-nrows b) 174 | beta 175 | c 176 | (real-nrows c)))) 177 | 178 | ;;; * Lapack 179 | ;;; 180 | ;;; Done: 181 | ;;; 182 | ;;; Need more work: 183 | ;;; xGELSY (no complex support). 184 | ;;; xPOTRF (incomplete, no tests) 185 | ;;; xPOTRI (incomplete, no tests) 186 | ;;; xGEQRF (incomplete, no tests) 187 | ;;; TODO: many many 188 | 189 | (defmacro call-with-work ((lwork work type) call) 190 | "This macro computes the needed workspace, and then recalls the 191 | function with the correct-sized array (appropriately allocated). 192 | lwork, work are the appropriate symbols, and type should be the 193 | replaceable type from def-lapack-method." 194 | (let ((element-type (fnv-type->element-type type))) 195 | `(let ((work (make-vector 1 :element-type ',element-type 196 | :implementation :foreign-array)) 197 | (,lwork -1)) 198 | ,call 199 | ;; We call twice to set lwork (first time is initial framework, 200 | ;; second time is actual computation). 201 | (setq ,lwork (floor (mref ,work 0 0))) 202 | (setq ,work (make-vector ,lwork :element-type ',element-type 203 | :implementation :foreign-array)) 204 | ,call))) 205 | 206 | (defun check-info (info function-name) 207 | (unless (= info 0) 208 | (error "~a: error in argument ~d" function-name (- info)))) 209 | 210 | -------------------------------------------------------------------------------- /src/lapack-qr.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-matrix) 2 | 3 | ;;; QR decomposition. 4 | 5 | ;;; Need one more front end to provide appropriate processing. A and 6 | ;;; TAU will have different values at the end, more appropriate to the 7 | ;;; transformation (i.e. will be the QR, but stored in common compact 8 | ;;; form). 9 | 10 | ;; M (input) INTEGER 11 | ;; The number of rows of the matrix A. M >= 0. 12 | ;; N (input) INTEGER 13 | ;; The number of columns of the matrix A. N >= 0. 14 | ;; A (input/output) DOUBLE PRECISION array, dimension (LDA,N) 15 | ;; On entry, the M-by-N matrix A. On exit, the elements on and 16 | ;; above the diagonal of the array contain the min(M,N)-by-N upper 17 | ;; trapezoidal matrix R (R is upper triangular if m >= n); the 18 | ;; elements below the diagonal, with the array TAU, represent the 19 | ;; orthogonal matrix Q as a product of min(m,n) elementary reflec‐ 20 | ;; tors (see Further Details). 21 | ;; LDA (input) INTEGER 22 | ;; The leading dimension of the array A. LDA >= max(1,M). 23 | ;; TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) 24 | ;; The scalar factors of the elementary reflectors (see Further 25 | ;; Details). 26 | ;; WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) 27 | ;; On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 28 | ;; LWORK (input) INTEGER 29 | ;; The dimension of the array WORK. LWORK >= max(1,N). For opti‐ 30 | ;; mum performance LWORK >= N*NB, where NB is the optimal block‐ 31 | ;; size. 32 | ;; If LWORK = -1, then a workspace query is assumed; the routine 33 | ;; only calculates the optimal size of the WORK array, returns 34 | ;; this value as the first entry of the WORK array, and no error 35 | ;; message related to LWORK is issued by XERBLA. 36 | ;; INFO (output) INTEGER 37 | ;; = 0: successful exit 38 | ;; < 0: if INFO = -i, the i-th argument had an illegal value 39 | 40 | (def-lapack-method geqrf ((a !matrix-type) 41 | ;; (tau !matrix-type) ; tau is for output 42 | ) 43 | (assert (<= (ncols a) (nrows a))) ; make sure A supports options 44 | (let ((info (make-fnv-int32 1 :initial-value 0)) 45 | (tau (make-matrix (nrows a) (ncols a) 46 | :element-type (element-type a)))) 47 | (with-copies ((a (or (not unit-strides-p) 48 | transposed-p)) 49 | (tau (or (not unit-strides-p) 50 | transposed-p))) 51 | (list a 52 | tau 53 | (check-info (fnv-int32-ref info 0) "GEQRF")) 54 | (call-with-work (lwork work !data-type) 55 | (!function (nrows a) 56 | (ncols a) 57 | a 58 | (max 1 (nrows a)) 59 | (data tau) 60 | (data work) 61 | lwork 62 | info))))) 63 | -------------------------------------------------------------------------------- /src/lapack-svd.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-matrix) 2 | 3 | ;;; SVD decomposition. 4 | 5 | #| 6 | DGESVD(3lapack) LAPACK driver routine (version 3.2) DGESVD(3lapack) 7 | 8 | NAME 9 | DGESVD - computes the singular value decomposition (SVD) of a real M-by-N matrix A, 10 | optionally computing the left and/or right singular vectors 11 | 12 | SYNOPSIS 13 | SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO 14 | ) 15 | 16 | CHARACTER JOBU, JOBVT 17 | 18 | INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N 19 | 20 | DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), VT( LDVT, * ), WORK( * 21 | ) 22 | 23 | PURPOSE 24 | DGESVD computes the singular value decomposition (SVD) of a real M-by-N matrix A, 25 | optionally computing the left and/or right singular vectors. The SVD is written 26 | A = U * SIGMA * transpose(V) 27 | where SIGMA is an M-by-N matrix which is zero except for its min(m,n) diagonal ele‐ 28 | ments, U is an M-by-M orthogonal matrix, and V is an N-by-N orthogonal matrix. The 29 | diagonal elements of SIGMA are the singular values of A; they are real and non-nega‐ 30 | tive, and are returned in descending order. The first min(m,n) columns of U and V 31 | are the left and right singular vectors of A. 32 | Note that the routine returns V**T, not V. 33 | 34 | ARGUMENTS 35 | JOBU (input) CHARACTER*1 36 | Specifies options for computing all or part of the matrix U: 37 | = 'A': all M columns of U are returned in array U: 38 | = 'S': the first min(m,n) columns of U (the left singular vectors) are 39 | returned in the array U; = 'O': the first min(m,n) columns of U (the left 40 | singular vectors) are overwritten on the array A; = 'N': no columns of U (no 41 | left singular vectors) are computed. 42 | 43 | JOBVT (input) CHARACTER*1 44 | Specifies options for computing all or part of the matrix V**T: 45 | = 'A': all N rows of V**T are returned in the array VT; 46 | = 'S': the first min(m,n) rows of V**T (the right singular vectors) are 47 | returned in the array VT; = 'O': the first min(m,n) rows of V**T (the right 48 | singular vectors) are overwritten on the array A; = 'N': no rows of V**T (no 49 | right singular vectors) are computed. JOBVT and JOBU cannot both be 'O'. 50 | 51 | M (input) INTEGER 52 | The number of rows of the input matrix A. M >= 0. 53 | 54 | N (input) INTEGER 55 | The number of columns of the input matrix A. N >= 0. 56 | 57 | A (input/output) DOUBLE PRECISION array, dimension (LDA,N) 58 | On entry, the M-by-N matrix A. On exit, if JOBU = 'O', A is overwritten 59 | with the first min(m,n) columns of U (the left singular vectors, stored 60 | columnwise); if JOBVT = 'O', A is overwritten with the first min(m,n) rows of 61 | V**T (the right singular vectors, stored rowwise); if JOBU .ne. 'O' and JOBVT 62 | .ne. 'O', the contents of A are destroyed. 63 | 64 | LDA (input) INTEGER 65 | The leading dimension of the array A. LDA >= max(1,M). 66 | 67 | S (output) DOUBLE PRECISION array, dimension (min(M,N)) 68 | The singular values of A, sorted so that S(i) >= S(i+1). 69 | 70 | U (output) DOUBLE PRECISION array, dimension (LDU,UCOL) 71 | (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. If JOBU = 'A', U con‐ 72 | tains the M-by-M orthogonal matrix U; if JOBU = 'S', U contains the first 73 | min(m,n) columns of U (the left singular vectors, stored columnwise); if JOBU 74 | = 'N' or 'O', U is not referenced. 75 | 76 | LDU (input) INTEGER 77 | The leading dimension of the array U. LDU >= 1; if JOBU = 'S' or 'A', LDU >= 78 | M. 79 | 80 | VT (output) DOUBLE PRECISION array, dimension (LDVT,N) 81 | If JOBVT = 'A', VT contains the N-by-N orthogonal matrix V**T; if JOBVT = 82 | 'S', VT contains the first min(m,n) rows of V**T (the right singular vectors, 83 | stored rowwise); if JOBVT = 'N' or 'O', VT is not referenced. 84 | 85 | LDVT (input) INTEGER 86 | The leading dimension of the array VT. LDVT >= 1; if JOBVT = 'A', LDVT >= N; 87 | if JOBVT = 'S', LDVT >= min(M,N). 88 | 89 | WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) 90 | On exit, if INFO = 0, WORK(1) returns the optimal LWORK; if INFO > 0, 91 | WORK(2:MIN(M,N)) contains the unconverged superdiagonal elements of an upper 92 | bidiagonal matrix B whose diagonal is in S (not necessarily sorted). B satis‐ 93 | fies A = U * B * VT, so it has the same singular values as A, and singular 94 | vectors related by U and VT. 95 | 96 | LWORK (input) INTEGER 97 | The dimension of the array WORK. LWORK >= 98 | MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). For good performance, LWORK should 99 | generally be larger. If LWORK = -1, then a workspace query is assumed; the 100 | routine only calculates the optimal size of the WORK array, returns this 101 | value as the first entry of the WORK array, and no error message related to 102 | LWORK is issued by XERBLA. 103 | 104 | INFO (output) INTEGER 105 | = 0: successful exit. 106 | < 0: if INFO = -i, the i-th argument had an illegal value. 107 | > 0: if DBDSQR did not converge, INFO specifies how many superdiagonals of 108 | an intermediate bidiagonal form B did not converge to zero. See the descrip‐ 109 | tion of WORK above for details. 110 | 111 | LAPACK driver routine (version 3.2) November 2008 DGESVD(3lapack) 112 | |# 113 | 114 | (def-lapack-method 115 | (gesvd 116 | :function-names ((%sgesvd single-float) 117 | (%dgesvd double-float))) 118 | ((a !matrix-type)) 119 | (assert (<= (ncols a) (nrows a))) ; make sure A supports options 120 | (let ((info (make-fnv-int32 1 :initial-value 0)) 121 | (u (make-matrix (nrows a) (nrows a) 122 | :element-type (element-type a))) 123 | (s (make-vector (min (nrows a) (ncols a)) 124 | :element-type (element-type a))) 125 | (vt (make-matrix (min (nrows a) (ncols a)) 126 | (ncols a) 127 | :element-type (element-type a))) 128 | 129 | ) 130 | (with-copies ((a (or (not unit-strides-p) 131 | transposed-p))) 132 | (list u s vt 133 | (check-info (fnv-int32-ref info 0) "GESVF")) 134 | (call-with-work (lwork work !data-type) 135 | (!function "A" ; jobu, see man page above. 136 | "A" ; jobvt, ditto 137 | (nrows a) ; m 138 | (ncols a) ; n 139 | a 140 | (real-nrows a) ; lda 141 | s 142 | u 143 | (nrows a) ; ldu 144 | vt 145 | (nrows vt) ; ldvt 146 | work lwork 147 | ;; complex needs: rwork. 148 | info))))) 149 | -------------------------------------------------------------------------------- /src/macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-matrix) 2 | 3 | (defmacro define-abstract-class (classname super-list &body body) 4 | "A wrapper for DEFCLASS that lets you define abstract base classes. 5 | If you try to instantiate an object of this class, a warning is signaled." 6 | `(progn 7 | (defclass ,classname ,super-list ,@body) 8 | 9 | ;; Protect against abstract class instantiation. 10 | 11 | ;; We could remove this programmatically later using a 12 | ;; compile-time constant (or even check the optimization options 13 | ;; and remove it if SAFETY is set low enough). 14 | (defmethod initialize-instance :before ((x ,classname) &key) 15 | (if (eql (type-of x) ',classname) 16 | (warn "~A is an abstract base class and not to be instantiated." 17 | (quote ',classname)))))) 18 | -------------------------------------------------------------------------------- /src/matrix-foreign-array.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-matrix) 2 | 3 | ;;;; * Matrices based on foreign arrays 4 | ;;;; 5 | ;;;; We implement here matrices based foreign arrays, implemented 6 | ;;;; through the foreign-numeric-vector (FNV) library. The 7 | ;;;; implementation will be named :FOREIGN-ARRAY, and specific 8 | ;;;; functions that we introduce will have "FA" in their name. 9 | 10 | ;;; Tony sez: We need to describe that these are usually in 11 | ;;; row-orientation (or column orientation? What do I know?? Why 12 | ;;; isn't it clear? Why havn't I doc'd it :-)? 13 | 14 | (eval-when (:compile-toplevel :load-toplevel :execute) 15 | (define-implementation :foreign-array "FA")) 16 | 17 | (defclass fa-matrix (matrix-like) ()) 18 | 19 | (defclass fa-vector (vector-like fa-matrix) ()) 20 | 21 | (defmethod implementation ((matrix fa-matrix)) 22 | :foreign-array) 23 | 24 | (defmethod make-matrix* (nrows ncols 25 | (matrix-implementation (eql :foreign-array)) 26 | &key element-type initial-element) 27 | (make-fa-matrix nrows ncols (element-type->fnv-type element-type) 28 | :initial-element initial-element)) 29 | 30 | (defgeneric make-fa-matrix (nrows ncols fnv-type 31 | &key initial-element) 32 | (:documentation "Same as MAKE-MATRIX*, but specific to matrix of 33 | implementation :FOREIGN-ARRAY and specialize on FNV-TYPE.")) 34 | 35 | ;;;; ** Typed matrices 36 | ;;;; 37 | ;;;; For classes representing typed matrices, we will base the class 38 | ;;;; names on the name used in the FNV library. 39 | 40 | (eval-when (:compile-toplevel :load-toplevel :execute) 41 | 42 | (defparameter *fnv-type-table* 43 | '((float . single-float) 44 | (double . double-float) 45 | (complex-float . (complex single-float)) 46 | (complex-double . (complex double-float)))) 47 | 48 | (defun fnv-type->element-type (fnv-type) 49 | "Return the lisp type corresponding to FNV-TYPE." 50 | (cdr (assoc fnv-type *fnv-type-table*))) 51 | 52 | (defun element-type->fnv-type (element-type) 53 | "Return the FNV type corresponding to ELEMENT-TYPE." 54 | (car (rassoc element-type *fnv-type-table* :test #'equal))) 55 | 56 | (defmacro construct-fa-matrix (element-type) 57 | (let* ((fnv-type (element-type->fnv-type element-type)) 58 | (fa-typed-mclass (matrix-class :simple :foreign-array element-type)) 59 | (fa-typed-vclass (vector-class :simple :foreign-array element-type)) 60 | (fa-typed-base-mclass (matrix-class :base :foreign-array element-type)) 61 | (fa-typed-base-vclass (vector-class :base :foreign-array element-type)) 62 | (fnv-mclass (make-symbol* "FNV-" fnv-type)) 63 | (fnv-ref (make-symbol* "FNV-" fnv-type "-REF")) 64 | (make-fnv (make-symbol* "MAKE-FNV-" fnv-type))) 65 | `(progn 66 | 67 | (make-matrix-class-hierarchy :foreign-array ,element-type) 68 | (make-vector-class-hierarchy :foreign-array ,element-type) 69 | 70 | (defclass ,fa-typed-mclass (,fa-typed-base-mclass) 71 | ((data :initarg :data 72 | :accessor data 73 | :type ,fnv-mclass 74 | :documentation "The FNV object holding the 75 | elements.")) 76 | (:documentation ,(format nil "Dense matrix holding ~ 77 | elements of type ~A, implemented as a foreign array." 78 | element-type))) 79 | 80 | (defclass ,fa-typed-vclass (,fa-typed-base-vclass 81 | ,fa-typed-mclass) 82 | () 83 | (:documentation ,(format nil "Dense vector holding ~ 84 | elements of type ~A, implemented as a foreign array." 85 | element-type))) 86 | 87 | (defmethod mref ((matrix ,fa-typed-mclass) i j) 88 | (,fnv-ref (data matrix) 89 | (flatten-matrix-indices matrix i j))) 90 | 91 | (defmethod (setf mref) (value (matrix ,fa-typed-mclass) i j) 92 | (setf (,fnv-ref (data matrix) 93 | (flatten-matrix-indices matrix i j)) 94 | value)) 95 | 96 | (defmethod vref ((vector ,fa-typed-mclass) i) 97 | (,fnv-ref (data vector) i)) 98 | 99 | (defmethod (setf vref) (value (vector ,fa-typed-mclass) i) 100 | (setf (,fnv-ref (data vector) i) value)) 101 | 102 | (defmethod make-fa-matrix (nrows ncols 103 | (fnv-type (eql ',fnv-type)) 104 | &key initial-element) 105 | (let ((data (,make-fnv (* nrows ncols) 106 | :initial-value initial-element))) 107 | (if (or (= nrows 1) (= ncols 1)) 108 | (make-instance ',fa-typed-vclass :nrows nrows 109 | :ncols ncols :data data) 110 | (make-instance ',fa-typed-mclass :nrows nrows 111 | :ncols ncols :data data)))))))) 112 | 113 | (construct-fa-matrix single-float) 114 | (construct-fa-matrix double-float) 115 | (construct-fa-matrix (complex single-float)) 116 | (construct-fa-matrix (complex double-float)) 117 | 118 | ;;; These don't exist yet...! 119 | ;;(construct-fa-matrix fixnum) 120 | ;;(construct-fa-matrix integer) 121 | -------------------------------------------------------------------------------- /src/matrix-lisp-array.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-matrix) 2 | 3 | ;;;; * Matrices based on lisp simple-arrays of rank 1 4 | ;;;; 5 | ;;;; We implement here matrices based on lisp simple-arrays of rank 1. 6 | ;;;; The implementation will be named :LISP-ARRAY, and specific 7 | ;;;; functions that we introduce will have "LA" in their name. 8 | 9 | ;;; Tony sez: We need to describe that these are usually in 10 | ;;; row-orientation (or column orientation? What do I know?? Why 11 | ;;; isn't it clear? Why havn't I doc'd it :-)? 12 | 13 | (eval-when (:compile-toplevel :load-toplevel :execute) 14 | (define-implementation :lisp-array "LA")) 15 | 16 | (defclass la-matrix (matrix-like) ()) 17 | 18 | (defclass la-vector (vector-like la-matrix) ()) 19 | 20 | (defmethod implementation ((matrix la-matrix)) 21 | :lisp-array) 22 | 23 | ;; FIXME: need to throw appropriate error when the indices are 24 | ;; illegal. what to throw: error? condition? 25 | ;; SOLN: tested, but poorly, via assertion in flatten-matrix-indices... 26 | ;; SOLN: proper, but not implemented, is to trap by condition. 27 | (defmethod mref ((matrix la-matrix) i j) 28 | (assert-valid-matrix-index matrix i j) 29 | (aref (data matrix) (flatten-matrix-indices matrix i j))) 30 | 31 | (defmethod (setf mref) (value (matrix la-matrix) i j) 32 | (setf (aref (data matrix) (flatten-matrix-indices matrix i j)) 33 | value)) 34 | 35 | (defmethod vref ((vector la-matrix) i) 36 | "We define VREF on LA-MATRIX instead of directly on LA-VECTOR since 37 | we can view a matrix as its underlying vector." 38 | (aref (data vector) i)) 39 | 40 | (defmethod (setf vref) (value (vector la-matrix) i) 41 | "We define (SETF VREF) on LA-MATRIX instead of directly on LA-VECTOR 42 | since we can view a matrix as its underlying vector." 43 | (setf (aref (data vector) i) value)) 44 | 45 | (defmethod make-matrix* (nrows ncols 46 | (matrix-implementation (eql :lisp-array)) 47 | &key element-type 48 | (initial-element nil initial-element-p)) 49 | (if (or (= nrows 1) (= ncols 1)) ;; make a vector if 1-dim 50 | (make-instance 51 | (la-vector-class element-type) 52 | :nrows nrows 53 | :ncols ncols 54 | :data (apply #'make-array (* nrows ncols) 55 | :element-type element-type 56 | (when initial-element-p 57 | (list :initial-element initial-element)))) 58 | (make-instance 59 | (la-matrix-class element-type) 60 | :nrows nrows 61 | :ncols ncols 62 | :data (apply #'make-array (* nrows ncols) 63 | :element-type element-type 64 | (when initial-element-p 65 | (list :initial-element initial-element)))))) 66 | 67 | ;;;; Also, some lisps (e.g., CLISP) fill the matrix with NIL if we 68 | ;;;; don't provide INITIAL-ELEMENT or an INITIAL-CONTENTS, so for 69 | ;;;; those we add an :AROUND method to make sure that the element 70 | ;;;; satisfies the element-type. 71 | 72 | #+clisp 73 | (defmethod make-matrix* :around 74 | (nrows ncols (matrix-implementation (eql :lisp-array)) 75 | &key element-type initial-element) 76 | (declare (ignore initial-element)) 77 | (let ((matrix (call-next-method))) 78 | (unless (or (zerop nrows) 79 | (zerop ncols) 80 | (typep (mref matrix 0 0) element-type)) 81 | (fill-matrix matrix (la-default-value element-type))) 82 | matrix)) 83 | 84 | (eval-when (:compile-toplevel :load-toplevel :execute) 85 | (defvar *la-default-value-table* nil 86 | "Table of default element types.")) 87 | 88 | (defun la-default-value (element-type) 89 | "Default value for a given ELEMENT-TYPE." 90 | (cdr (assoc element-type *la-default-value-table* :test #'equal))) 91 | 92 | (defun add-la-default-value (element-type value) 93 | "Add VALUE as default value for ELEMENT-TYPE." 94 | (pushnew (cons element-type value) 95 | *la-default-value-table* :test #'equal)) 96 | 97 | (defmethod fill-matrix ((matrix la-matrix) fill-element) 98 | (fill (data matrix) fill-element) 99 | matrix) 100 | 101 | ;;;; ** Typed matrices 102 | 103 | ;; LA = lisp-array, vs foreign-array. 104 | 105 | (eval-when (:compile-toplevel :load-toplevel :execute) 106 | 107 | (defun la-matrix-class (element-type &optional (type :simple)) 108 | "Return the LA-MATRIX class name corresponding to ELEMENT-TYPE." 109 | (matrix-class type :lisp-array element-type)) 110 | 111 | (defun la-vector-class (element-type &optional (type :simple)) 112 | "Return the LA-VECTOR class name corresponding to ELEMENT-TYPE." 113 | (vector-class type :lisp-array element-type)) 114 | 115 | (defmacro construct-la-matrix (element-type default-value) 116 | "Construct a matrix class holding elements of type ELEMENT-TYPE 117 | based on lisp arrays." 118 | (let* ((la-typed-mclass (la-matrix-class element-type :simple)) 119 | (la-typed-base-mclass (la-matrix-class element-type :base)) 120 | (la-typed-vclass (la-vector-class element-type :simple)) 121 | (la-typed-base-vclass (la-vector-class element-type :base))) 122 | `(progn 123 | 124 | (add-la-default-value ',element-type ,default-value) 125 | 126 | (make-matrix-class-hierarchy :lisp-array ,element-type) 127 | (make-vector-class-hierarchy :lisp-array ,element-type) 128 | 129 | (defclass ,la-typed-mclass (,la-typed-base-mclass) 130 | ((data :initarg :data 131 | :accessor data 132 | :type (simple-array ,element-type (*)) 133 | :documentation "The lisp simple-array of rank 1 134 | holding the elements.")) 135 | (:documentation ,(format nil "Dense matrix holding ~ 136 | elements of type ~A, implemented as a lisp array." 137 | element-type))) 138 | 139 | (defclass ,la-typed-vclass (,la-typed-base-vclass 140 | ,la-typed-mclass) 141 | () 142 | (:documentation ,(format nil "Dense vector holding ~ 143 | elements of type ~A, implemented as a lisp array." 144 | element-type))))))) 145 | 146 | ;; Make all of our matrix types 147 | (construct-la-matrix single-float 0.0) 148 | (construct-la-matrix double-float 0d0) 149 | (construct-la-matrix (complex single-float) #C(0.0 0.0)) 150 | (construct-la-matrix (complex double-float) #C(0d0 0d0)) 151 | (construct-la-matrix fixnum 0) 152 | (construct-la-matrix integer 0) 153 | (construct-la-matrix t nil) 154 | -------------------------------------------------------------------------------- /src/matrix-operations.lisp: -------------------------------------------------------------------------------- 1 | ;;; need license and etc data. 2 | 3 | ;;; This file contains lisp-centric matrix manipulations which aren't 4 | ;;; necessarily sophisticated numerical linear algebra. However, it 5 | ;;; relies on BLAS/LAPACK for reasonably numerical ops, and lisp for 6 | ;;; "standard" non-numerical ops such as bind (should we overload 7 | ;;; concatenate instead?) 8 | 9 | ;;; access to substructures should be found in [matrix|vector].lisp. 10 | 11 | (in-package :lisp-matrix) 12 | 13 | (defmacro with-typed-values ((&rest bindings) matrix &body body) 14 | "Each binding in BINDINGS is of the form (VARIABLE VALUE). VARIABLE 15 | is bound to VALUE coerced to the element type of MATRIX." 16 | (with-unique-names (element-type) 17 | (labels ((make-coerced-binding (binding) 18 | (destructuring-bind (variable value) binding 19 | `(,variable (coerce ,value ,element-type))))) 20 | `(let ((,element-type (element-type ,matrix))) 21 | (let (,@(mapcar #'make-coerced-binding bindings)) 22 | ,@body))))) 23 | 24 | (defgeneric m* (a b) 25 | (:documentation "Matrix multiplication: A * B. Defaults to the 26 | element type of the first matrix. 27 | 28 | Better approach would be to consider lowest-common-type?") 29 | (:method ((a matrix-like) (b matrix-like)) 30 | (assert (= (ncols a) (nrows b))) ;; insist on squareness... 31 | (with-typed-values ((one 1) 32 | (zero 0)) a 33 | (let ((c (make-matrix (nrows a) (ncols b) 34 | :element-type (element-type a)))) 35 | (gemm one a b zero c))))) 36 | 37 | (defgeneric m+ (a b) 38 | (:documentation "Matrix addition: A + B.") 39 | (:method ((a matrix-like) (b matrix-like)) 40 | (with-typed-values ((one 1)) a 41 | (axpy one a (copy b))))) 42 | 43 | (defgeneric m- (a b) 44 | (:documentation "Matrix subtraction: A - B.") 45 | (:method ((a matrix-like) (b matrix-like)) 46 | (with-typed-values ((minus-one -1)) a 47 | (axpy minus-one b (copy a)))) 48 | #|;; must handle more types! Somehow we are missing something... 49 | (:method ((mata matrix-like) (matb matrix-like)) 50 | (assert (and (equal (matrix-dimensions mata) 51 | (matrix-dimensions matb)))) 52 | (let ((result (make-matrix (values-list (matrix-dimensions mata))))) 53 | (dotimes (i (matrix-dimension mata 0)) 54 | (dotimes (j (matrix-dimension mata 1)) 55 | (setf (mref result i j) (- (mref mata i j) (mref matb i j))))) 56 | result))) 57 | |# 58 | ) 59 | 60 | ;; TODO: SUM is not yet done 61 | #+ (or) 62 | (defgeneric sum (matrix) 63 | (:documentation "") 64 | (:method ((matrix matrix-like)) 65 | (asum matrix))) 66 | 67 | 68 | ;;; We need to consider the equivalent of rbind/cbind operations, for 69 | ;;; building larger matrices from smaller but "dimension-matching" 70 | ;;; matrices. 71 | 72 | 73 | ;; next variant, bind, should handle "unlimited" arguments to bind 74 | ;; together. There might be a destructuring bind, 75 | ;; i.e. metabang-bind-style, where we manage to specify the structure 76 | ;; and how to remove, and given a proposed structure, how to put in. 77 | (defgeneric bind2 (m1 m2 &key by) 78 | (:documentation "Simple experiment, not necessarily part of the API 79 | yet! When type is :row, If the number of columns of m1 and m2 80 | match, join them. Think of a sandwich approach, resulting in: 81 | 82 | m1 83 | -- 84 | m2 85 | 86 | The ARGS can be matrices, vectors, or lists. Arguments are bound 87 | into a matrix along their rows. Example: 88 | 89 | (bind2 #2a((1 2)(3 4)) #(5 6) :by :row) 90 | returns 91 | #2a((1 2)(3 4)(5 6)) 92 | 93 | When type is :column, if the number of rows of m1 and m2 match, join 94 | them. Think of a pair of columns, resulting in 95 | 96 | m1 | m2 97 | 98 | API should result with the ARGS as matrices, vectors, or 99 | lists. Arguments are bound into a matrix along their columns. 100 | Example: 101 | (bind2 #2a((1 2)(3 4)) #(5 6) :by :column) 102 | returns 103 | #2a((1 2 5)(3 4 6))")) 104 | 105 | (defmethod bind2 ((m1 matrix-like) (m2 matrix-like) &key (by :row)) 106 | "Binding for matrix, columns, deep copy into a new matrix of the 107 | right size. Could we solve the row-binding approach by transpose?" 108 | (ecase by 109 | (:column ;; mostly right 110 | (progn 111 | (assert (= (nrows m1) (nrows m2))) 112 | (let* ((nr (nrows m1)) 113 | (nc (+ (ncols m1) (ncols m2))) 114 | (mincol (min (ncols m1) (ncols m2))) 115 | (addcol (- (max (ncols m1) (ncols m2)) 116 | (min (ncols m1) (ncols m2)))) 117 | (m (make-matrix nr nc))) 118 | (dotimes (i nr) 119 | (dotimes (j mincol) ; copy equal parts 120 | (setf (mref m i j) (mref m1 i j)) 121 | (setf (mref m i (+ j (ncols m1))) (mref m2 i j))) 122 | (if (> (ncols m1) (ncols m2)) ; copy the excess part 123 | (dotimes (j addcol) (setf (mref m i (+ j mincol)) 124 | (mref m1 i (+ j mincol)))) 125 | (dotimes (j addcol) (setf (mref m i (+ j mincol (ncols m1))) 126 | (mref m2 i (+ j mincol )))))) 127 | m))) 128 | (:row ;; mostly wrong 129 | (progn 130 | (assert (= (ncols m1) (ncols m2))) 131 | (let* ((nr (+ (nrows m1) (nrows m2))) 132 | (nc (ncols m1)) 133 | (minrow (min (nrows m1) (nrows m2))) 134 | (addrow (- (max (nrows m1) (nrows m2)) 135 | (min (nrows m1) (nrows m2)))) 136 | (m (make-matrix nr nc))) 137 | (dotimes (j nc) 138 | (dotimes (i minrow) ; copy equal parts 139 | (setf (mref m i j) (mref m1 i j)) 140 | (setf (mref m (+ i (nrows m1)) j) (mref m2 i j))) 141 | (if (> (nrows m1) (nrows m2)) ; copy the excess part 142 | (dotimes (i addrow) (setf (mref m (+ i minrow) j) 143 | (mref m1 (+ i minrow) j))) 144 | (dotimes (i addrow) (setf (mref m (+ i minrow (nrows m1)) j) 145 | (mref m2 (+ i minrow) j))))) 146 | m))) 147 | (t (error "Problems")))) 148 | 149 | 150 | 151 | 152 | ;;; also on the list would be outer-product, but that should come from 153 | ;;; LAPACK? 154 | 155 | (defgeneric cross-product (mata matb)) 156 | 157 | #| 158 | 159 | (defgeneric outer-product (mata matb &optional op) 160 | (:documentation "compute outer product of 2 arrays.") 161 | (:method ((mata t) (matb t) &optional (op t)) 162 | (error 163 | "Outer Product not implemented for objects of type ~S and ~S" 164 | mata matb)) 165 | (:method ((mata matrix-like) 166 | (matb matrix-like) 167 | &optional 168 | (op t)) 169 | 170 | (let* ((resultdims (list (xdims 1 mata) 171 | (xdims 2 mata) 172 | (xdims 1 matb) 173 | (xdims 2 matb))) 174 | (mresult (make-array resultdims))) 175 | (loop 176 | over i j k l in resultdims 177 | (setf (xref mresult i j k l) 178 | (funcall op 179 | (xref mata i j) (xref matb j k)))) 180 | mresult))) 181 | |# 182 | 183 | 184 | 185 | 186 | 187 | ;;; Element-wide operations. API is similar to matlisp 188 | 189 | (defgeneric m.+ (mata matb) 190 | (:documentation "same as m+ which is inherently an element-wise operation.") 191 | (:method ((mata matrix-like) (matb matrix-like)) (m+ mata matb))) 192 | 193 | 194 | (defgeneric m.- (mata matb) 195 | (:documentation "same as m- which is inherently an element-wise operation.") 196 | (:method ((mata matrix-like) (matb matrix-like)) (m- mata matb))) 197 | 198 | 199 | (defgeneric m.* (mata matb) 200 | (:documentation "same as m+ which is inherently an element-wise 201 | operation. How should we handle coercion? probably the right way to 202 | do this will be to consider the least specific form, and coerce 203 | back. HOWEVER, this could be done simpler by barfing (forcing 204 | explicit coercion) and this would be safer, numerically.") 205 | (:method ((mata matrix-like) (matb matrix-like)) 206 | (assert (and (equal (matrix-dimensions mata) 207 | (matrix-dimensions matb)))) 208 | (let ((result (make-matrix (matrix-dimension mata 0) 209 | (matrix-dimension mata 1)))) 210 | (dotimes (i (matrix-dimension mata 0)) 211 | (dotimes (j (matrix-dimension mata 1)) 212 | (setf (mref result i j) (* (mref mata i j) (mref matb i j))))) 213 | result))) 214 | 215 | 216 | 217 | (defgeneric m./ (mata matb) 218 | (:documentation "same as m+ which is inherently an element-wise 219 | operation. How should we handle coercion? probably the right way to 220 | do this will be to consider the least specific form, and coerce 221 | back. HOWEVER, this could be done simpler by barfing (forcing 222 | explicit coercion) and this would be safer, numerically.") 223 | (:method ((mata matrix-like) (matb matrix-like)) 224 | (assert (and (equal (matrix-dimensions mata) 225 | (matrix-dimensions matb)))) 226 | (let ((result (make-matrix (matrix-dimension mata 0) 227 | (matrix-dimension mata 1)))) 228 | (dotimes (i (matrix-dimension mata 0)) 229 | (dotimes (j (matrix-dimension mata 1)) 230 | (setf (mref result i j) (/ (mref mata i j) (mref matb i j))))) 231 | result))) 232 | 233 | ;;; Need equiv of R's apply or the googly python's map-reduce 234 | 235 | (defun list-of-rows (M) 236 | "Returns a list of vector-like elements from matrix M. 237 | FIXME: AWFUL IMPLEMENTATION" 238 | (let ((result nil)) 239 | (dotimes (i (nrows M)) 240 | (setf result (append result (list (row M i)) ))) 241 | result)) 242 | ;;(list-of-rows m01) 243 | 244 | (defun list-of-columns (M) 245 | "Returns a list of vector-like elements from matrix M. 246 | FIXME: AWFUL." 247 | (let ((result nil)) 248 | (dotimes (i (ncols M)) 249 | (setf result (append result (list (col M i))))) 250 | result)) 251 | #| 252 | ;; Is this right? 253 | (defun list-of-margins (M margin-type)) ;; 254 | (defun list-of-matrix-partitions (M partition-walker)) ; could be 255 | ; generalized to return diff 256 | ; types. 257 | (defun list-of-vector-partitions (M partition-walker)) 258 | |# 259 | 260 | ;; (defgeneric map-matrix (withfn mat &key iterator result-type) 261 | ;; (:documentation "equivalent of R's apply commands. But with a sense 262 | ;; of extensibility.") 263 | ;; (:method (withfn (mat 'vector-like) &key iterator result-type) 264 | ;; (let ((result)) 265 | ;; ))) 266 | 267 | ;;; Need to add a walker in the sense of the affi accessor approach, 268 | ;;; but needs to have a reset, 269 | 270 | 271 | ;;; LAPACK-related numerical linear algebra. Should we be precise? 272 | 273 | #| 274 | (defmethod qr-decomp (a) 275 | (:documentation "Compute the QR decomposition of matrix A") 276 | (:method ( (a fa-matrix-double)) 277 | (let ((tau (make-fnv-int32 (min (nrows a) (ncols a)) :initial-value 0))) 278 | (dgeqrf a tau) 279 | (values a tau)))) 280 | |# 281 | -------------------------------------------------------------------------------- /src/numerical-linear-algebra.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp -*- 2 | 3 | ;;; Time-stamp: <2013-12-26 13:17:21 tony> 4 | ;;; Creation: <2009-02-05 11:18:51 tony> 5 | ;;; File: numerical-linear-algebra.lisp 6 | ;;; Author: AJ Rossini 7 | ;;; Copyright: (c)2009--, AJ Rossini. BSD, LLGPL, or GPLv2, depending 8 | ;;; on how it arrives. 9 | ;;; Purpose: Lispy interface to factorization/decomposition, 10 | 11 | ;;; What is this talk of 'release'? Klingons do not make software 12 | ;;; 'releases'. Our software 'escapes', leaving a bloody trail of 13 | ;;; designers and quality assurance people in its wake. 14 | 15 | (in-package :lisp-matrix) 16 | 17 | ;;; Matrix Factorization for stable processing 18 | 19 | ;; current factorization types, only worried about "high-level" 20 | ;; descriptions, not further ramifications (size/spce considerations). 21 | 22 | ;; we have: SVD, LU, QR, Cholesky. 23 | ;; note that some are "special case only" factorizations. 24 | 25 | (defclass factorized-matrix-results () 26 | ((results 27 | :initarg :results 28 | :initform nil 29 | :reader results) 30 | (factorization-type 31 | :initarg :type 32 | :initform nil 33 | :reader factorization-type))) 34 | 35 | (defgeneric factorized-matrix (a) 36 | (:documentation "Return the matrix (and not the structure). The 37 | latter is the standard result from factorization routine. ") 38 | (:method ((a factorized-matrix-results)) 39 | (ecase (factorization-type a) 40 | (:qr ) 41 | (:lu ) 42 | (:cholesky) 43 | (:svd))) 44 | (:method ((a matrix-like)) 45 | (warn "Returning same matrix, assuming prior factorization."))) 46 | 47 | (defgeneric factorize (a &key by) 48 | (:documentation "matrix decomposition, M -> SVD/LU/AtA etc. 49 | FIXME: do we want a default type? If BY is NIL then return A untouched.") 50 | #| Move to CLS.git 51 | (:method ((a data-frame-like) &key by) 52 | (factorize (data-frame-like->matrix-like a) :by by)) 53 | |# 54 | (:method ((a matrix-like) &key (by :qr)) ;; is this the right way to get :qr as default? 55 | (make-instance 'factorized-matrix-results 56 | :results (case by 57 | (:qr (geqrf a)) 58 | (:lu (getrf a)) 59 | (:cholesky (potrf a)) 60 | (:svd (gesvd a)) 61 | (otherwise a)) 62 | :type by))) 63 | 64 | (defgeneric invert (a &optional by) 65 | (:documentation "compute inverse of A using the appropriate factorization.") 66 | (:method ((a factorized-matrix-results) &optional by) 67 | (unless (equal by (factorization-type a)) 68 | (warn "method to factor BY does not match FACTORIZATION-TYPE.")) 69 | (let ((results (ecase (factorization-type a) 70 | (:qr (error "not implemented, is there an obvious lapack/blas fcn?" )) 71 | (:lu a ) ;; FIXME! 72 | (:cholesky (potri a)) 73 | (:svd (error "not implemented, is there an obvious lapack/blas fcn?" )) 74 | (:otherwise 75 | (error 76 | "Unimplemented or not a proper factorized-matrix type ~A." 77 | (factorization-type a)))))) 78 | results)) 79 | (:method ((a matrix-like) &optional by) 80 | (if (not by) (setf by :qr)) 81 | (let ((results (ecase by 82 | (:qr (error "not implemented, is there an obvious lapack/blas fcn?" )) 83 | (:lu (minv-lu a)) 84 | (:cholesky (if (matrix-like-symmetric-p a) 85 | (minv-cholesky a) 86 | (error "Cholesky only works for symmetric matrices."))) 87 | (:svd (error "not implemented, is there an obvious lapack/blas fcn?" )) 88 | (:otherwise 89 | (error 90 | "Unimplemented or not a proper factorized-matrix type ~A." 91 | (factorization-type a)))))) 92 | results))) 93 | 94 | 95 | ;;; [W|G]LS solutions 96 | 97 | ;; gelsy 98 | ;; gels 99 | 100 | (defgeneric least-squares (y x &key w) 101 | (:documentation "Compute the (weighted/generalized) least-squares solution B to W(Y-XB)") 102 | (:method ((y vector-like) (x matrix-like) &key w) 103 | (check-type w vector-like) 104 | (error "implement me!"))) 105 | 106 | ;;; Eigensystems 107 | 108 | (defgeneric eigensystems (x) 109 | (:documentation "Compute the eigenvectors and values of X.") 110 | (:method ((x matrix-like)) 111 | (error "implement me!"))) 112 | 113 | #| 114 | ;;; Optimization: should we put this someowhere else? It is similar 115 | ;;; to Least Squares, which is one method for optimization, but is 116 | ;;; also similar to root-finding 117 | 118 | (defgeneric optimize (f data params &key method maximize-p) 119 | (:documentation "given a function F, F(DATA,PARAMS), compute the 120 | PARAM values that optimize F for DATA, using METHOD, and maximize or 121 | minimize according to MAXIMIZE-P.") 122 | (:method ((f function) (data matrix-like) (params vector-like) 123 | &key method maximize-p) 124 | (error "implement me!")) 125 | (:method ((f function) (data array) (params vector) 126 | &key method maximize-p) 127 | (error "implement me!"))) 128 | 129 | (defgeneric root-find (f data params &key method) 130 | (:documentation "given a function F, F(DATA,PARAMS), compute PARAM 131 | such that with DATA, we use METHOD to solve F(DATA,PARAM)=0.") 132 | (:method ((f function) (data matrix-like) (params vector-like) 133 | &key method) 134 | (error "implement me!")) 135 | (:method ((f function) (data array) (params vector) 136 | &key method) 137 | (error "implement me!"))) 138 | |# 139 | -------------------------------------------------------------------------------- /src/old/fnv-vector.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-matrix) 2 | 3 | 4 | (define-abstract-class vector-like () 5 | ((nelts :initarg :nelts 6 | :initform 0 7 | :reader nelts 8 | :documentation "Number of elements in this vector (view)")) 9 | (:documentation "Abstract base class for vectors and vector views 10 | whose elements are stored in a foreign-numeric-vector.")) 11 | 12 | (defgeneric vector-dimension (x) 13 | (:documentation "Like ARRAY-DIMENSION for vector-like objects.") 14 | (:method ((x vector-like)) 15 | (nelts x))) 16 | 17 | (defmethod initialize-instance :after ((x vector-like) &key) 18 | "Make sure that the vector-like object has a valid (non-negative) 19 | number of elements." 20 | (if (< (nelts x) 0) 21 | (error "VECTOR-LIKE objects cannot have a negative number ~A of elements." 22 | (nelts x)))) 23 | 24 | (define-abstract-class vecview (vector-like) 25 | ((parent :initarg :parent 26 | :reader parent 27 | :documentation "The \"parent\" object to which this vector 28 | view relates.")) 29 | (:documentation "An abstract class representing a \"view\" into a vector. 30 | That view may be treated as a (readable and writeable) 31 | reference to the elements of the matrix.")) 32 | 33 | (defgeneric make-vector (nelts fnv-type &key initial-element 34 | initial-contents) 35 | (:documentation "Generic method for creating a vector, given the 36 | number of elements NELTS, and optionally either an initial element 37 | INITIAL-ELEMENT or the initial contents INITIAL-CONTENTS (a 1-D 38 | array with dimension NELTS), which are deep-copied into the 39 | resulting vector.")) 40 | 41 | (defgeneric vref (a i) 42 | (:documentation "Like AREF buf for vectors.")) 43 | 44 | ;;; Internal generic functions 45 | 46 | (defgeneric fnv-type-to-vector-type (type vector-category) 47 | (:documentation "Given a particular FNV type (such as 48 | 'complex-float) and a keyword indicating the kind of vector (:VECTOR 49 | or :SLICE), returns the corresponding specific vector type.")) 50 | 51 | (defgeneric vector-type-to-fnv-type (type) 52 | (:documentation "Return the FNV type (such as 'COMPLEX-FLOAT) 53 | corresponding to a given type of vector (such as 54 | 'VECTOR-COMPLEX-FLOAT or 'VECTOR-SLICE-COMPLEX-FLOAT).")) 55 | 56 | ;;; Macro to make the actual matrix classes 57 | 58 | (eval-when (:compile-toplevel :load-toplevel) 59 | 60 | (defmacro make-typed-vector (fnv-type) 61 | "Template constructor macro for VECTOR and related object types that 62 | hold data using FNV objects of type FNV-TYPE (which is the FNV datatype 63 | suffix, such as complex-double, float, double, etc.)." 64 | (let ((fnv-ref (make-symbol* "FNV-" fnv-type "-REF")) 65 | (make-fnv (make-symbol* "MAKE-FNV-" fnv-type)) 66 | (vector-type-name (make-symbol* "VECTOR-" fnv-type)) 67 | (vector-slice-type-name (make-symbol* "VECTOR-SLICE-" fnv-type))) 68 | 69 | `(progn 70 | (defclass ,vector-type-name (vector-like) 71 | ((data :initarg :data 72 | ;; No INITFORM provided because users aren't supposed to 73 | ;; initialize this object directly, only by calling the 74 | ;; appropriate "generic" factory function. 75 | :documentation "The FNV object holding the elements." 76 | :reader data)) 77 | (:documentation ,(format nil "Dense vector holding elements of type ~A" fnv-type))) 78 | 79 | (defmethod vref ((A ,vector-type-name) i) 80 | (declare (type fixnum i)) 81 | (,fnv-ref (data A) i)) 82 | 83 | ;; TODO: set up SETF to work with VREF. 84 | 85 | (defclass ,vector-slice-type-name (vecview) 86 | ((offset :initarg :offset 87 | :initform 0 88 | :reader offset) 89 | (stride :initarg :stride 90 | :initform 1 91 | :reader stride))) 92 | 93 | (defmethod vref ((A ,vector-slice-type-name) i) 94 | (declare (type fixnum i)) 95 | (with-slots (parent offset stride) A 96 | (vref parent (+ offset (* i stride))))) 97 | 98 | (defmethod fnv-type-to-vector-type ((type (eql ',fnv-type)) 99 | vector-category) 100 | (cond ((eq vector-category :vector) 101 | ',vector-type-name) 102 | ((eq vector-category :slice) 103 | ',vector-slice-type-name) 104 | (t 105 | (error "Invalid vector type ~A" vector-category)))) 106 | 107 | (defmethod vector-type-to-fnv-type 108 | ((type (eql ',vector-type-name))) 109 | ',fnv-type) 110 | (defmethod vector-type-to-fnv-type 111 | ((type (eql ',vector-slice-type-name))) 112 | ',fnv-type) 113 | (defmethod fnv-type ((x ,vector-type-name)) 114 | ',fnv-type) 115 | (defmethod fnv-type ((x ,vector-slice-type-name)) 116 | ',fnv-type) 117 | 118 | (defmethod make-vector (nelts (fnv-type (eql ',fnv-type)) &key 119 | (initial-element 0) 120 | (initial-contents nil initial-contents-p)) 121 | ;; Logic for handling initial contents or initial element. 122 | ;; Initial contents take precedence (if they are specified, 123 | ;; then any supplied initial-element argument is ignored). 124 | (let ((data 125 | (cond 126 | (initial-contents-p 127 | (let ((fnv (,make-fnv nelts))) 128 | (dotimes (i nelts fnv) 129 | ;; FIXME: INITIAL-CONTENTS may be a list as 130 | ;; in MAKE-ARRAY -- Evan Monroig 2008.04.24 131 | (setf (,fnv-ref fnv i) 132 | (aref initial-contents i))))) 133 | (t 134 | (,make-fnv nelts 135 | :initial-value initial-element))))) 136 | (make-instance ',vector-type-name 137 | :nelts nelts 138 | :data data))))))) 139 | 140 | ;;; Instantiate the classes and methods. 141 | (make-typed-vector double) 142 | (make-typed-vector float) 143 | (make-typed-vector complex-double) 144 | (make-typed-vector complex-float) 145 | 146 | (defgeneric slice (x &key offset stride nelts) 147 | (:documentation "Returns a \"slice\" (readable and writeable 148 | reference to a potentially strided range of elements) of the given 149 | vector-like object x.") 150 | (:method ((x vector-like) 151 | &key (offset 0) (stride 1) (nelts (nelts x))) 152 | (make-instance (fnv-type-to-vector-type (fnv-type x) :slice) 153 | :parent x 154 | :nelts nelts 155 | :offset offset 156 | :stride stride))) 157 | 158 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp -*- 2 | 3 | ;;; Time-stamp: <2011-03-17 11:59:42 tony> 4 | ;;; Creation: ?? 5 | ;;; File: package.lisp 6 | ;;; Author: mfh 7 | ;;; Maintainer: AJ Rossini 8 | ;;; Copyright: (c)2009--2011, AJ Rossini. Currently licensed under MIT 9 | ;;; license. See file LICENSE.mit in top-level directory 10 | ;;; for information. 11 | ;;; Purpose: lisp-matrix package definition. 12 | 13 | ;;; What is this talk of 'release'? Klingons do not make software 14 | ;;; 'releases'. Our software 'escapes', leaving a bloody trail of 15 | ;;; designers and quality assurance people in its wake. 16 | 17 | (in-package :cl-user) 18 | 19 | (defpackage :lisp-matrix 20 | (:use :cl 21 | :xarray 22 | :cffi 23 | :cl-utilities 24 | :org.middleangle.foreign-numeric-vector 25 | :org.middleangle.cl-blapack 26 | :ffa) 27 | (:export 28 | 29 | ;; base classes (need we export more?) and informtion 30 | matrix-like vector-like 31 | 32 | ;; basic instantiations 33 | make-matrix make-matrix* 34 | strides-class 35 | strides unit-strides-p 36 | window-class window 37 | transpose-class transpose-matrix transposed-p 38 | 39 | zero-offset-p 40 | offset 41 | row-offset col-offset 42 | row-stride col-stride 43 | 44 | ones zeros eye rand ;; types 45 | copy copy! copy* 46 | copy-maybe copy-maybe* 47 | fill-matrix 48 | 49 | m= m* m+ m- 50 | m.* m.+ m.- 51 | v= v* v+ v- v/ 52 | ;; v* v+ v- ; these are inherited from m-based ops, but 53 | 54 | ;; have a slight issue with still needing a v.* variant, 55 | ;; since v* would inherit from m*, which needs appropriate 56 | ;; matrix multiplication. 57 | ;; Do we define these as non-oriented methods? (i.e. with 58 | ;; Nx1 and 1xN methods doing the right thing when added 59 | ;; together? Currently, we'd barf on the mis-alignment. 60 | ;; Solution: v# do elt-wise, not matrix-approach. 61 | 62 | print-object 63 | mref data row col 64 | nelts nrows ncols 65 | matrix-dimension matrix-dimensions 66 | orientation valid-orientation-p opposite-orientation 67 | flatten-matrix-indices flatten-matrix-indices-1 68 | 69 | vref vector-dimension 70 | 71 | la-simple-matrix-double la-simple-matrix-integer 72 | la-simple-matrix-single 73 | la-simple-matrix-complex-single 74 | la-simple-matrix-complex-double 75 | ;; Next symbols are guesses at... wrong? 76 | la-simple-matrix-fixnum 77 | 78 | la-simple-vector-double 79 | la-simple-vector-single 80 | la-simple-vector-integer 81 | la-simple-vector-complex-single 82 | la-simple-vector-complex-double 83 | 84 | la-slice-vecview-double 85 | la-slice-vecview-single 86 | la-slice-vecview-integer 87 | la-slice-vecview-complex-double 88 | la-slice-vecview-complex-single 89 | 90 | ;; Next paragrah of symbols are guesses... wrong? 91 | fa-simple-matrix-double 92 | fa-simple-matrix-integer 93 | fa-simple-matrix-complex 94 | fa-simple-matrix-float 95 | fa-simple-matrix-fixnum 96 | fa-simple-vector-double 97 | fa-simple-vector-integer 98 | 99 | col-vector-p 100 | make-vector 101 | parent 102 | real-stride 103 | row-vector-p 104 | map-vec 105 | 106 | ;; exported BLAS/LAPACK, the "simple" versions which handle the 107 | ;; various types (double, complex-float, integer, etc...) 108 | gemm scal 109 | iamax asum nrm2 axpy slice 110 | dot dotc dotu 111 | gelsy 112 | 113 | ;; data storage modes and defaults. 114 | *supported-datatypes* datatype->letter 115 | float double complex-float complex-double 116 | single-float double-float 117 | *default-element-type* 118 | 119 | ;; actual storage place (lisp or foreign) 120 | *implementations* *default-implementation* 121 | 122 | make-predicate make-predicate-macro 123 | 124 | assert-valid-matrix-index 125 | 126 | window-matview strided-matview 127 | 128 | bind2 129 | 130 | diagonal! diagonalf 131 | list-of-rows list-of-columns 132 | 133 | getrf getri getrs minv-lu msolve-lu;; LU, general 134 | potrf potri potrs minv-cholesky msolve-cholesky ;; cholesky, symm matrices 135 | geqrf ;; qr 136 | 137 | matrix-like-symmetric-p 138 | 139 | cross-product ;; outer-product 140 | 141 | ;; data transforms 142 | list->vector-like vector-like->list 143 | trap2mat )) 144 | 145 | 146 | (defpackage :lisp-matrix-user 147 | (:documentation "User experimentation package for lisp-matrix") 148 | (:use :cl 149 | :lisp-matrix)) 150 | 151 | (defpackage :lisp-matrix-unittests 152 | (:documentation "Unit, validation, and regression testing for lisp-matrix") 153 | (:use :common-lisp 154 | :lift 155 | :lisp-matrix) 156 | (:export run-lisp-matrix-tests)) 157 | -------------------------------------------------------------------------------- /src/unittests/test-lift.lisp: -------------------------------------------------------------------------------- 1 | 2 | ;;; This file is used to support interactive testing for LISP-MATRIX 3 | ;;; it manages to remind (me) how to stage the development. 4 | 5 | (ql:quickload :lisp-matrix) 6 | 7 | (in-package :lisp-matrix-unittests) 8 | 9 | (describe (run-lisp-matrix-tests)) ; long summary 10 | ;; current: 69 tests, 2 errors 11 | 12 | 13 | ;;;; code for memory 14 | 15 | ;; (run-lisp-matrix-tests) ; quick summary 16 | ;;(remove-test :test-case 'data-initialize :suite 'lisp-matrix-ut) 17 | ;;(remove-test :test-case 'test-2 :suite 'lisp-matrix-ut-matrix-gemm) 18 | 19 | ;; EVERYTHING 20 | ;; (run-lisp-matrix-tests) 21 | ;; (describe (run-lisp-matrix-tests)) 22 | 23 | (describe (run-test :test-case 'bind2-dims-conditions)) 24 | (describe (run-test :test-case 'r-apply-columns)) 25 | (describe (run-test :test-case 'diagonalf-vectors)) 26 | (describe (run-test :test-case 'diagonal!-vectors)) 27 | 28 | 29 | ;; VECTOR TESTS 30 | ;; (run-tests :suite 'lisp-matrix-ut-vectors) 31 | ;; (describe (run-tests :suite 'lisp-matrix-ut-vectors)) 32 | ;; (run-test :test-case ' :suite 'lisp-matrix-ut-vectors) 33 | 34 | ;; REMINDER IF NEEDED 35 | ;; (remove-test :test-case 'data-initialize :suite 'lisp-matrix-ut) 36 | 37 | -------------------------------------------------------------------------------- /src/unittests/test.lisp: -------------------------------------------------------------------------------- 1 | 2 | ;;; This file is used to support interactive testing for LISP-MATRIX 3 | ;;; it manages to remind (me) how to stage the development. 4 | 5 | (ql:quickload :lisp-matrix) 6 | 7 | (in-package :lisp-matrix-unittests) 8 | 9 | (describe (run-lisp-matrix-tests)) ; long summary 10 | ;; current: 69 tests, 2 errors 11 | 12 | 13 | ;;;; code for memory 14 | 15 | ;; (run-lisp-matrix-tests) ; quick summary 16 | ;;(remove-test :test-case 'data-initialize :suite 'lisp-matrix-ut) 17 | ;;(remove-test :test-case 'test-2 :suite 'lisp-matrix-ut-matrix-gemm) 18 | 19 | ;; EVERYTHING 20 | ;; (run-lisp-matrix-tests) 21 | ;; (describe (run-lisp-matrix-tests)) 22 | 23 | (describe (run-test :test-case 'bind2-dims-conditions)) 24 | (describe (run-test :test-case 'r-apply-columns)) 25 | (describe (run-test :test-case 'diagonalf-vectors)) 26 | (describe (run-test :test-case 'diagonal!-vectors)) 27 | 28 | 29 | ;; VECTOR TESTS 30 | ;; (run-tests :suite 'lisp-matrix-ut-vectors) 31 | ;; (describe (run-tests :suite 'lisp-matrix-ut-vectors)) 32 | ;; (run-test :test-case ' :suite 'lisp-matrix-ut-vectors) 33 | 34 | ;; REMINDER IF NEEDED 35 | ;; (remove-test :test-case 'data-initialize :suite 'lisp-matrix-ut) 36 | 37 | -------------------------------------------------------------------------------- /src/unittests/unittests-matrix-view.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp -*- 2 | ;;; Copyright (c) 2007, by A.J. Rossini 3 | ;;; See COPYRIGHT file for any additional restrictions (BSD license). 4 | ;;; Since 1991, ANSI was finally finished. Edited for ANSI Common Lisp. 5 | 6 | ;;; This is semi-external to lisp-matrix core package. The dependency 7 | ;;; should be that lisp-matrix packages are dependencies for the unit 8 | ;;; tests. However, where they will end up is still to be 9 | ;;; determined. 10 | 11 | (in-package :lisp-matrix-unittests) 12 | 13 | ;; See file:test.lisp in this directory for debugging with LIFT. 14 | 15 | ;;; EXTERNAL 16 | 17 | ;;; TEST SUITES 18 | 19 | (deftestsuite lisp-matrix-ut-matrix-views (lisp-matrix-ut-matrix) ()) 20 | 21 | ;;; SUPPORT FUNCTIONS 22 | 23 | ;;; TESTS: MATRIX-VIEWS 24 | 25 | (addtest (lisp-matrix-ut-matrix-views) 26 | fun-transpose 27 | (for-all-implementations 28 | (let ((a (rand 3 4))) 29 | (ensure (eq a (transpose-matrix (transpose-matrix a))))))) 30 | 31 | (addtest (lisp-matrix-ut-matrix-views) 32 | fun-window 33 | (for-all-implementations 34 | (let ((a (rand 3 4))) 35 | (ensure (eq a (parent (window (window a :ncols 2) 36 | :nrows 2)))) 37 | (ensure (m= (window (window a :ncols 2) :nrows 2) 38 | (window a :ncols 2 :nrows 2)))))) 39 | 40 | (addtest (lisp-matrix-ut-matrix-views) 41 | fun-strides 42 | (for-all-implementations 43 | (let ((a (rand 3 4))) 44 | (ensure (eql (class-name (class-of (strides a :nrows 2))) 45 | (window-class a))) 46 | (ensure (eq a (parent (strides (strides a :ncols 2 :col-stride 2)))))))) 47 | 48 | 49 | (addtest (lisp-matrix-ut-matrix-views) 50 | indexing-views 51 | (let* ((m3 (make-matrix 6 5 :initial-contents '((1d0 2d0 3d0 4d0 5d0) 52 | (6d0 7d0 8d0 9d0 10d0) 53 | (11d0 12d0 13d0 14d0 15d0) 54 | (16d0 17d0 18d0 19d0 20d0) 55 | (21d0 22d0 23d0 24d0 25d0) 56 | (26d0 27d0 28d0 29d0 30d0)))) 57 | (m4 (strides m3 :nrows 2 :row-stride 2))) 58 | (ensure (v= (row m4 1) 59 | (col (transpose-matrix m4) 1) )) 60 | (ensure (v= (col m3 1) (row (transpose-matrix m3) 1)) ) 61 | (ensure (v= (row m3 1) (col (transpose-matrix m3) 1))))) 62 | 63 | -------------------------------------------------------------------------------- /src/unittests/unittests-transform.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp -*- 2 | ;;; 3 | ;;; Copyright (c) 2007--2008, by A.J. Rossini 4 | ;;; See COPYRIGHT file for any additional restrictions (BSD license). 5 | ;;; Since 1991, ANSI was finally finished. Edited for ANSI Common Lisp. 6 | 7 | ;;; This is part of the unittests package. See unittests.lisp for 8 | ;;; general philosophy. 9 | 10 | (in-package :lisp-matrix-unittests) 11 | 12 | ;; See file:test.lisp in this directory for debugging with LIFT. 13 | 14 | ;;; TEST SUITES 15 | 16 | (deftestsuite lisp-matrix-ut-datatrans (lisp-matrix-ut) ()) 17 | 18 | ;;; SUPPORT FUNCTIONS 19 | 20 | ;;; TESTS: VECTORS 21 | 22 | (addtest (lisp-matrix-ut-datatrans) 23 | list-to-vector-like-row 24 | (for-all-implementations 25 | (ensure (m= (make-vector 3 26 | :initial-element 0d0 27 | :type :row ) 28 | (list->vector-like (list 0d0 0d0 0d0) 29 | :orientation :row))))) 30 | 31 | (addtest (lisp-matrix-ut-datatrans) 32 | list-to-vector-like-column 33 | (for-all-implementations 34 | (ensure (m= (make-vector 3 35 | :initial-element 0d0 36 | :type :column ) 37 | (list->vector-like (list 0d0 0d0 0d0) 38 | :orientation :column))))) 39 | 40 | -------------------------------------------------------------------------------- /src/unittests/unittests-vector.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp -*- 2 | ;;; 3 | ;;; Copyright (c) 2007--2014, by A.J. Rossini 4 | ;;; See COPYRIGHT file for any additional restrictions (BSD license). 5 | ;;; Since 1991, ANSI was finally finished. Edited for ANSI Common Lisp. 6 | 7 | ;;; This is part of the unittests package. See unittests.lisp for 8 | ;;; general philosophy. 9 | 10 | (in-package :lisp-matrix-unittests) 11 | 12 | ;; See file:test.lisp in this directory for debugging with LIFT. 13 | 14 | ;;; TEST SUITES in file. 15 | 16 | (deftestsuite lisp-matrix-ut-vectors (lisp-matrix-ut) ()) 17 | (deftestsuite lisp-matrix-ut-vectors-gemm (lisp-matrix-ut-vectors) ()) 18 | 19 | ;;; SUPPORT FUNCTIONS 20 | 21 | ;;; TESTS: VECTORS 22 | 23 | (addtest (lisp-matrix-ut-vectors) 24 | construct-vectors-and-same-as-matrix 25 | (for-all-implementations 26 | (ensure (m= (make-vector 3 :initial-element 0d0) 27 | (make-matrix 1 3 :initial-element 0d0))) 28 | (ensure (m= (make-vector 3 :initial-element 0d0 :type :column) 29 | (make-matrix 3 1 :initial-element 0d0))) 30 | (ensure (col-vector-p (rand 3 1))) 31 | (ensure (row-vector-p (rand 1 3))) 32 | 33 | ;; FIXME: M x 1 or 1 x M matrices should not be considered 34 | ;; transposed when we think of their storage. But we cannot 35 | ;; transpose them without resorting to a TRANSPOSE-VECVIEW. So it 36 | ;; would be best to introduce a function like STORAGE-TRANSPOSED-P 37 | ;; (ensure (not (transposed-p (transpose-matrix (make-matrix 1 10))))) 38 | ;; (ensure (not (transposed-p (transpose-matrix (make-matrix 10 1))))) 39 | 40 | ;; transpose should return the original matrix if dimensions are 41 | ;; 1 x 1 42 | (let ((m (rand 1 1))) 43 | (ensure (eq m (transpose-matrix m)))))) 44 | 45 | (addtest (lisp-matrix-ut-vectors) 46 | matview-row-and-col-access-and-equiv 47 | (for-all-implementations 48 | (let ((a (rand 7 9))) 49 | ;; strides and window should return vectors when appropriate 50 | (ensure (row-vector-p (window a :nrows 1))) 51 | (ensure (col-vector-p (window a :ncols 1))) 52 | ;; column access and row access, matviews. 53 | (dotimes (i 7) 54 | (ensure (v= (row a i) (col (transpose-matrix a) i))) 55 | (ensure (not (m= (row a i) (col (transpose-matrix a) i)))) 56 | (ensure (row-vector-p (row a i))) 57 | (ensure (col-vector-p (col a i))) 58 | (ensure (row-vector-p (row (transpose-matrix a) i))) 59 | (ensure (col-vector-p (col (transpose-matrix a) i))))))) 60 | 61 | 62 | (addtest (lisp-matrix-ut-vectors) 63 | strided-matrix-row-access 64 | (let* ((a (make-matrix 6 5 :initial-contents '((1d0 2d0 3d0 4d0 5d0) 65 | (6d0 7d0 8d0 9d0 10d0) 66 | (11d0 12d0 13d0 14d0 15d0) 67 | (16d0 17d0 18d0 19d0 20d0) 68 | (21d0 22d0 23d0 24d0 25d0) 69 | (26d0 27d0 28d0 29d0 30d0)))) 70 | (b (strides a :nrows 3 :row-stride 2))) ;; need an indexed variant 71 | (ensure (m= (row b 0) 72 | (make-matrix 1 5 :initial-contents '((1d0 2d0 3d0 4d0 5d0))))) 73 | ;; (ensure (m= (princ (row b 0) ) 74 | ;; (princ (make-matrix 1 5 :initial-contents '((1d0 2d0 3d0 4d0 5d0))))) ) 75 | (ensure (m= (row b 1) 76 | (make-matrix 1 5 :initial-contents '((11d0 12d0 13d0 14d0 15d0))))) 77 | (ensure (m= (row b 2) 78 | (make-matrix 1 5 :initial-contents '((21d0 22d0 23d0 24d0 25d0))))))) 79 | 80 | 81 | (addtest (lisp-matrix-ut-vectors) 82 | strided-matrix-column-access 83 | (let* ((a (make-matrix 6 5 :initial-contents '((1d0 2d0 3d0 4d0 5d0) 84 | (6d0 7d0 8d0 9d0 10d0) 85 | (11d0 12d0 13d0 14d0 15d0) 86 | (16d0 17d0 18d0 19d0 20d0) 87 | (21d0 22d0 23d0 24d0 25d0) 88 | (26d0 27d0 28d0 29d0 30d0)))) 89 | (b (strides a :nrows 3 :row-stride 2))) 90 | ;; (princ b) 91 | ;; (ensure (m= (princ (col b 0)) 92 | ;; (princ (make-matrix 3 1 :initial-contents '((1d0) (11d0) (21d0)))))) 93 | ;; (ensure (m= (princ (col b 1)) 94 | ;; (princ (make-matrix 3 1 :initial-contents '((2d0) (12d0) (22d0)))))) 95 | ;; (ensure (m= (princ (col b 2) ) 96 | ;; (princ (make-matrix 3 1 :initial-contents '((3d0) (13d0) (23d0)))))) 97 | (ensure (m= (col b 0) 98 | (make-matrix 3 1 :initial-contents '((1d0) (11d0) (21d0))))) 99 | (ensure (m= (col b 1) 100 | (make-matrix 3 1 :initial-contents '((2d0) (12d0) (22d0))))) 101 | (ensure (m= (col b 2) 102 | (make-matrix 3 1 :initial-contents '((3d0) (13d0) (23d0))))) 103 | (ensure (m= (col b 3) 104 | (make-matrix 3 1 :initial-contents '((4d0) (14d0) (24d0))))) 105 | (ensure (m= (col b 4) 106 | (make-matrix 3 1 :initial-contents '((5d0) (15d0) (25d0))))))) 107 | 108 | (addtest (lisp-matrix-ut-vectors) 109 | v=-col-row-transpose 110 | (let ((a (rand 3 4))) 111 | (dotimes (i 2) 112 | (ensure (v= (row a i) (col (transpose-matrix a) i))) 113 | (ensure (v= (col a i) (row (transpose-matrix a) i)))))) 114 | 115 | (addtest (lisp-matrix-ut-vectors) 116 | row-of-window 117 | (let* ((a (rand 5 10 :element-type 'integer :value 10)) 118 | (b (window a :row-offset 1 :nrows 4 :col-offset 2 :ncols 5))) 119 | (dotimes (i 4) 120 | (ensure (m= (row b i) 121 | (window a :row-offset (+ i 1) :nrows 1 :col-offset 2 :ncols 5))))) 122 | (let* ((a (rand 10 5 :element-type 'integer :value 10)) 123 | (b (window (transpose-matrix a) :row-offset 1 :nrows 4 :col-offset 2 :ncols 5))) 124 | 125 | (dotimes (i 4) 126 | (ensure (m= (row b i) 127 | (window (transpose-matrix a) :row-offset (+ i 1) :nrows 1 :col-offset 2 128 | :ncols 5)))))) 129 | 130 | (addtest (lisp-matrix-ut-vectors) 131 | real-stride 132 | (ensure (= 1 (real-stride (zeros 2 2)))) 133 | (ensure (= 2 (real-stride (row (zeros 2 2) 0)))) 134 | (ensure (= 1 (real-stride (col (zeros 2 2) 0)))) 135 | (ensure (= 1 (real-stride (row (transpose-matrix (zeros 2 2)) 0)))) 136 | (ensure (= 2 (real-stride (col (transpose-matrix (zeros 2 2)) 0)))) 137 | (ensure (null (real-stride (window (zeros 4 4) :nrows 2))))) 138 | 139 | 140 | (addtest (lisp-matrix-ut-vectors-gemm) 141 | m*-vectors 142 | (for-all-implementations 143 | (let* ((a (make-matrix 4 4 :initial-contents '((0d0 1d0 2d0 3d0) 144 | (1d0 2d0 3d0 4d0) 145 | (2d0 3d0 4d0 5d0) 146 | (3d0 4d0 5d0 6d0)))) 147 | (x (slice (col a 3) :stride 2 :nelts 2 :type :row)) 148 | (y (slice (col a 2) :stride 2 :nelts 2 :type :column))) 149 | (ensure (m= x (make-matrix 1 2 :initial-contents '((3d0 5d0))))) 150 | (ensure (m= y (make-matrix 2 1 :initial-contents '((2d0) (4d0))))) 151 | (ensure (m= (m* x y) (scal 26d0 (ones 1 1)))) 152 | (ensure (m= (m* y x) (make-matrix 2 2 :initial-contents '((6d0 10d0) 153 | (12d0 20d0)))))) 154 | (ensure (m= (m* (ones 1 10) (ones 10 1)) 155 | (scal 10d0 (ones 1 1)))) 156 | (ensure (m= (m* (ones 10 1) 157 | (scal 2d0 (ones 1 10))) 158 | (scal 2d0 (ones 10 10)))))) 159 | 160 | 161 | 162 | ;;; DIAGONAL CLASS TESTS 163 | 164 | (addtest (lisp-matrix-ut-vectors) 165 | diagonal!-vectors 166 | (for-all-implementations 167 | (let* ((a (make-matrix 4 4 168 | :initial-contents '((0d0 1d0 2d0 3d0) 169 | (1d0 2d0 3d0 4d0) 170 | (2d0 3d0 4d0 5d0) 171 | (3d0 4d0 5d0 6d0)))) 172 | (b (make-matrix 1 4 173 | :initial-contents '((0d0 2d0 4d0 6d0)))) 174 | (c (make-vector 4 175 | :initial-contents '((0d0 2d0 4d0 6d0)) 176 | :type :row)) 177 | (d (make-vector 4 178 | :initial-contents '((0d0)( 2d0)( 4d0)( 6d0)) 179 | :type :column))) 180 | (ensure (m= (diagonal! a) 181 | b)) 182 | (ensure (m= (diagonal! (transpose-matrix a)) 183 | b)) 184 | (ensure (v= (diagonal! a) 185 | b)) 186 | (ensure (v= (diagonal! (transpose-matrix a)) 187 | b))))) 188 | 189 | 190 | 191 | (addtest (lisp-matrix-ut-vectors) 192 | diagonalf-vectors 193 | (for-all-implementations 194 | (let* ((a (make-matrix 4 4 195 | :initial-contents '((0d0 1d0 2d0 3d0) 196 | (1d0 2d0 3d0 4d0) 197 | (2d0 3d0 4d0 5d0) 198 | (3d0 4d0 5d0 6d0)))) 199 | (b (make-matrix 1 4 200 | :initial-contents '((0d0 2d0 4d0 6d0)))) 201 | (c (make-vector 4 202 | :initial-contents '((0d0 2d0 4d0 6d0)) 203 | :type :row)) 204 | (d (make-vector 4 205 | :initial-contents '((0d0)( 2d0)( 4d0)( 6d0)) 206 | :type :column))) 207 | (ensure (m= (diagonalf a) 208 | b)) 209 | (ensure (m= (diagonalf (transpose-matrix a)) 210 | b)) 211 | (ensure (v= (diagonalf a) 212 | b)) 213 | (ensure (v= (diagonalf (transpose-matrix a)) 214 | b))))) 215 | 216 | ;;;; Vectors 217 | 218 | (addtest (lisp-matrix-ut-vectors) 219 | vector-op-v+ 220 | (for-all-implementations 221 | (let* ((a (make-vector 4 :initial-contents '((1d0 2d0 3d0 4d0)))) 222 | (b (make-vector 4 :initial-contents '((10d0 20d0 30d0 40d0)))) 223 | (c (make-vector 4 :initial-contents '((11d0 22d0 33d0 44d0))))) 224 | (ensure (v= (v+ a b) 225 | c)) 226 | (ensure (v= (v+ b a) 227 | c))))) 228 | 229 | (addtest (lisp-matrix-ut-vectors) 230 | vector-op-v- 231 | (for-all-implementations 232 | (let* ((a (make-vector 4 :initial-contents '((1d0 2d0 3d0 4d0)))) 233 | (b (make-vector 4 :initial-contents '((10d0 20d0 30d0 40d0)))) 234 | (c (make-vector 4 :initial-contents '((-9d0 -18d0 -27d0 -36d0)))) 235 | (d (make-vector 4 :initial-contents '((9d0 18d0 27d0 36d0))))) 236 | (ensure (v= (v- a b) 237 | c)) 238 | (ensure (v= (v- b a) 239 | d))))) 240 | 241 | (addtest (lisp-matrix-ut-vectors) 242 | vector-op-v* 243 | (for-all-implementations 244 | (let* ((a (make-vector 4 :initial-contents '((1d0 2d0 3d0 4d0)))) 245 | (b (make-vector 4 :initial-contents '((10d0 20d0 30d0 40d0)))) 246 | (c (make-vector 4 :initial-contents '((10d0 40d0 90d0 160d0))))) 247 | (ensure (v= (v* a b) 248 | c)) 249 | (ensure (v= (v* b a) 250 | c))))) 251 | 252 | (addtest (lisp-matrix-ut-vectors) 253 | vector-op-v/ 254 | (for-all-implementations 255 | (let* ((a (make-vector 4 :initial-contents '((1d0 2d0 3d0 4d0)))) 256 | (b (make-vector 4 :initial-contents '((10d0 20d0 30d0 40d0)))) 257 | (c (make-vector 4 :initial-contents '((10d0 10d0 10d0 10d0)))) 258 | (d (make-vector 4 :initial-contents '((0.1d0 0.1d0 0.1d0 0.1d0))))) 259 | (ensure (v= (v/ a b) 260 | d)) 261 | (ensure (v= (v/ b a) 262 | c))))) 263 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | ;; License: MH, BSD/MIT -- fill in details! 2 | 3 | ;; DSL support tools. 4 | 5 | (in-package :lisp-matrix) 6 | 7 | (defun make-symbol* (&rest args) 8 | "build a symbol by concatenating each element of ARGS, and intern it 9 | in the current package. Elements can be strings or symbols." 10 | (intern (apply #'concatenate 'string 11 | (mapcar (lambda (arg) 12 | (etypecase arg 13 | (symbol (symbol-name arg)) 14 | (string arg))) 15 | args)))) 16 | 17 | 18 | ;;; (make-symbol* "test" "me") => |testme| , :INTERNAL 19 | ;;; (make-symbol* "test" 'metoo "me") => |testMETOOme| , :INTERNAL 20 | ;;; (make-symbol* "TEsT" 'metoo "me") => |TEsTMETOOme| , :INTERNAL 21 | -------------------------------------------------------------------------------- /src/xarray-lispmatrix.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp -*- 2 | 3 | ;;; Time-stamp: <2013-12-26 13:13:00 tony> 4 | ;;; Creation: <2009-06-26 07:57:23 tony> 5 | ;;; File: xarray-lispmatrix.lisp 6 | ;;; Author: AJ Rossini 7 | ;;; Copyright: (c)2009--, AJ Rossini. BSD, LLGPL, or GPLv2, depending 8 | ;;; on how it arrives. 9 | ;;; Purpose: Integration with xarray to provide a common CLOS-based 10 | ;;; array-like indexing approach. 11 | 12 | ;;; What is this talk of 'release'? Klingons do not make software 13 | ;;; 'releases'. Our software 'escapes', leaving a bloody trail of 14 | ;;; designers and quality assurance people in its wake. 15 | 16 | ;;; This organization and structure is new to the 21st Century 17 | ;;; version.. Think, "21st Century Schizoid Man". 18 | 19 | (in-package :lisp-matrix) 20 | 21 | ;; might need to condition on the existence of and accessibility of xarray, 22 | ;; something like: 23 | #| 24 | (when (find-package 'xarray) 25 | 26 | (defmethod xtype ((object matrix-like))) 27 | .... ) 28 | |# 29 | 30 | (defmethod xtype ((object matrix-like)) 31 | (warning "Not implemented for matrix-like virtual class")) 32 | 33 | (defmethod xrank ((object matrix-like)) 34 | (warning "Not implemented for matrix-like virtual class")) 35 | 36 | 37 | (defmethod xdims ((object matrix-like)) 38 | (warning "Not implemented for matrix-like virtual class")) 39 | ;; (defmethod xdims*) can just use the default method. 40 | (defmethod xdim ((object matrix-like)) 41 | (warning "Not implemented for matrix-like virtual class")) 42 | (defmethod xsize ((object matrix-like)) 43 | (warning "Not implemented for matrix-like virtual class")) 44 | (defmethod xref-writable-p ((object matrix-like) &rest subscripts) 45 | "Always true for matrix-like derived classes at this point (right?)" 46 | t) 47 | (defmethod xref ((object matrix-like) &rest subscripts) 48 | (mref object subscripts)) 49 | 50 | (defmethod (setf xref) (value (object matrix-like) &rest subscripts)) 51 | 52 | 53 | ;; there is a default method that should suffice, but perhaps some 54 | ;; direct tricks could make this more efficient? Worth a look 55 | ;; LATER. 56 | (defmethod xsetf ((destination matrix-like) 57 | (source matrix-like) 58 | &key map-function)) 59 | 60 | ;; (defmethod take) ; default should work for now. 61 | 62 | 63 | 64 | --------------------------------------------------------------------------------