├── .gitignore ├── APIdemo ├── Makefile.in ├── aclocal.m4 ├── configure.in ├── generic │ └── lsvd.c ├── pkgIndex.tcl.in ├── tclconfig │ ├── ChangeLog │ ├── README.txt │ ├── install-sh │ └── tcl.m4 └── win │ ├── makefile.vc │ ├── nmakehlp.c │ ├── rules.vc │ └── sample.rc ├── LICENSES ├── COPYRIGHT.f2c ├── COPYRIGHT.hsfft └── COPYRIGHT.lapack ├── Makefile.in ├── README.md ├── TkBridge ├── Makefile.in ├── aclocal.m4 ├── configure ├── configure.in ├── generic │ └── vectk.c ├── pkgIndex.tcl.in ├── somloi_galuska.png ├── tclconfig │ ├── ChangeLog │ ├── README.txt │ ├── install-sh │ └── tcl.m4 ├── testrun.tcl └── win │ ├── makefile.vc │ ├── nmakehlp.c │ ├── rules.vc │ └── sample.rc ├── WavReader ├── Makefile.in ├── aclocal.m4 ├── configure.in ├── generic │ └── wavreader.c ├── pkgIndex.tcl.in ├── tclconfig │ ├── ChangeLog │ ├── README.txt │ ├── install-sh │ └── tcl.m4 ├── testrun.tcl └── win │ ├── makefile.vc │ ├── nmakehlp.c │ ├── rules.vc │ └── sample.rc ├── aclocal.m4 ├── benchmark ├── bench_comp.gnuplot ├── bench_linreg.tcl ├── bench_memcpy.tcl ├── bench_setup.gnuplot ├── bench_solvesys.tcl └── vecfbench.tcl ├── build ├── kbs.tcl └── vectcl.pkg ├── configure ├── configure.in ├── demo ├── 3dcanvas.tcl ├── autodiff.tcl ├── cube3d.tcl ├── householder.tcl ├── plot.tcl ├── somloi_galuska.png └── vectcl2015demo.tcl ├── generic ├── arrayshape.c ├── arrayshape.h ├── assignop.h ├── assignop_loop.h ├── bccodes.h ├── bcexecute.c ├── bcexecute.h ├── binop.h ├── binop_loop.h ├── clapack_cutdown.c ├── clapack_cutdown.h ├── compathack.c ├── compathack.h ├── compathack.tcl.c ├── defs.tcl ├── dotproductloop.h ├── eig.c ├── eig.h ├── f2c.h ├── f2c_mathlib.h ├── fft.c ├── fft.h ├── hsfft.c ├── hsfft.h ├── intconv.c ├── intconv.h ├── linalg.c ├── linalg.h ├── map.h ├── nacomplex.c ├── nacomplex.h ├── reduction.h ├── schur.c ├── schur.h ├── svd.c ├── svd.h ├── tcl_xerbla.c ├── uniop.h ├── vectcl.c ├── vectcl.h ├── vectcl.tcl.c ├── vectcl.tcl.h ├── vectclInt.h ├── vectclapi.c ├── vexpr.peg ├── vmparser.c ├── vmparser.h └── vmparserules.h ├── gentest.tcl ├── license.terms ├── lsqbench.tcl ├── pkgIndex.tcl.in ├── tcl86_vectcl.patch ├── tclconfig ├── ChangeLog ├── README.txt ├── install-sh └── tcl.m4 ├── tea ├── app_config_options.txt ├── app_makefiles.txt ├── codingstyle.txt ├── design.txt ├── introduction.txt ├── makefiles.txt ├── packages.txt ├── stubs.txt ├── toman.tcl ├── writingdocs.txt └── writingtests.txt ├── teapot.txt.in ├── tests ├── all.tcl ├── compiler.test ├── concat.test ├── datatypes.test ├── iterator.test ├── linalg.test ├── nrcache ├── reduction.test └── vectcl.test ├── tools ├── cherrypick_clapack.tcl ├── expand.tcl └── parsergen.tcl ├── vectclConfig.sh.in ├── vexpr.tcl └── win ├── makefile.vc ├── nmakehlp.c ├── rules.vc └── sample.rc /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | -------------------------------------------------------------------------------- /APIdemo/aclocal.m4: -------------------------------------------------------------------------------- 1 | # 2 | # Include the TEA standard macro set 3 | # 4 | 5 | builtin(include,tclconfig/tcl.m4) 6 | 7 | # 8 | # Add here whatever m4 macros you want to define for your package 9 | # 10 | -------------------------------------------------------------------------------- /APIdemo/generic/lsvd.c: -------------------------------------------------------------------------------- 1 | /* Sample file for wrapping a LAPACK function 2 | * (dgesvd / zgesvd) 3 | */ 4 | #include 5 | #include 6 | #include 7 | #include 8 | #define MAX(x, y) ((x)>(y)?x:y) 9 | #define MIN(x, y) ((x)<(y)?x:y) 10 | 11 | int LapackSVDCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { 12 | if (objc != 2) { 13 | Tcl_WrongNumArgs(interp, 1, objv, "matrix"); 14 | return TCL_ERROR; 15 | } 16 | 17 | Tcl_Obj *matrix = objv[1]; 18 | 19 | /* Convert the 1st argument to VecTcl object */ 20 | NumArrayInfo *info = NumArrayGetInfoFromObj(interp, matrix); 21 | if (!info) { return TCL_ERROR; } 22 | 23 | /* Check that it is a matrix */ 24 | if (info->nDim != 2) { 25 | Tcl_SetResult(interp, "SVD only defined for 2D matrix", NULL); 26 | return TCL_ERROR; 27 | } 28 | 29 | long int m = info->dims[0]; 30 | long int n = info->dims[1]; 31 | 32 | if (info->type != NumArray_Complex128) { 33 | /* Real-valued matrix, prepare for dgesvd */ 34 | /* create a column-major copy of matrix 35 | * This also converts an integer matrix to double */ 36 | Tcl_Obj *A = NumArrayNewMatrixColMaj(NumArray_Float64, m, n); 37 | NumArrayObjCopy(interp, matrix, A); 38 | /* create a real matrix for U and V */ 39 | Tcl_Obj *U = NumArrayNewMatrixColMaj(NumArray_Float64, m, m); 40 | Tcl_Obj *V = NumArrayNewMatrixColMaj(NumArray_Float64, n, n); 41 | /* create a real vector for the singular values */ 42 | Tcl_Obj *s = NumArrayNewVector(NumArray_Float64, MIN(m,n)); 43 | 44 | /* Extract the raw pointers from the VecTcl objects */ 45 | double *Aptr = NumArrayGetPtrFromObj(interp, A); 46 | double *Uptr = NumArrayGetPtrFromObj(interp, U); 47 | double *Vptr = NumArrayGetPtrFromObj(interp, V); 48 | double *sptr = NumArrayGetPtrFromObj(interp, s); 49 | 50 | /* setup workspace arrays */ 51 | long int lwork=MAX(MAX(1,3*MIN(m,n)+MAX(m,n)),5*MIN(m,n)); 52 | double* work=ckalloc(sizeof(double)*lwork); 53 | long int lda = m; 54 | /* Leading dimensions. We made a fresh copy for A and 55 | * new matrices U, V, therefore we have the full matrices */ 56 | long int ldu = m; 57 | long int ldvt = n; 58 | long int info; 59 | 60 | /* 61 | int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n, 62 | doublereal *a, integer *lda, doublereal *s, doublereal *u, integer * 63 | ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, 64 | integer *info) */ 65 | 66 | /* call out to zgesvd */ 67 | dgesvd_("A", "A", &m, &n, 68 | Aptr, &lda, sptr, Uptr, 69 | &ldu, Vptr, &ldvt, work, 70 | &lwork, &info); 71 | 72 | /* free workspace */ 73 | ckfree(work); 74 | /* A is also overwritten with junk */ 75 | Tcl_DecrRefCount(A); 76 | 77 | /* join U, s, V into a list*/ 78 | Tcl_Obj *result = Tcl_NewObj(); 79 | Tcl_ListObjAppendElement(NULL, result, U); 80 | Tcl_ListObjAppendElement(NULL, result, s); 81 | Tcl_ListObjAppendElement(NULL, result, V); 82 | Tcl_SetObjResult(interp, result); 83 | return TCL_OK; 84 | 85 | 86 | } else { 87 | /* For complex values, prepare for ZGESVD */ 88 | /* create a column-major copy of matrix */ 89 | Tcl_Obj *A = NumArrayNewMatrixColMaj(NumArray_Complex128, m, n); 90 | NumArrayObjCopy(interp, matrix, A); 91 | /* create a complex matrix for U and V */ 92 | Tcl_Obj *U = NumArrayNewMatrixColMaj(NumArray_Complex128, m, m); 93 | Tcl_Obj *V = NumArrayNewMatrixColMaj(NumArray_Complex128, n, n); 94 | /* create a real vector for the singular values */ 95 | Tcl_Obj *s = NumArrayNewVector(NumArray_Float64, MIN(m,n)); 96 | 97 | /* Extract the raw pointers from the VecTcl objects */ 98 | NumArray_Complex *Aptr = NumArrayGetPtrFromObj(interp, A); 99 | NumArray_Complex *Uptr = NumArrayGetPtrFromObj(interp, U); 100 | NumArray_Complex *Vptr = NumArrayGetPtrFromObj(interp, V); 101 | double *sptr = NumArrayGetPtrFromObj(interp, s); 102 | 103 | /* setup workspace arrays */ 104 | long int lwork=MAX(1,2*MIN(m,n)+MAX(m,n)); 105 | NumArray_Complex* work=ckalloc(sizeof(NumArray_Complex)*lwork); 106 | double *rwork = ckalloc(5*MIN(m,n)); 107 | long int lda = m; 108 | long int ldu = m; 109 | long int ldvt = n; 110 | long int info; 111 | 112 | /* 113 | int zgesvd_(char *jobu, char *jobvt, integer *m, integer *n, 114 | doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u, 115 | integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work, 116 | integer *lwork, doublereal *rwork, integer *info) */ 117 | 118 | /* call out to zgesvd */ 119 | zgesvd_("A", "A", &m, &n, 120 | Aptr, &lda, sptr, Uptr, 121 | &ldu, Vptr, &ldvt, work, 122 | &lwork, rwork, &info); 123 | 124 | /* free workspace */ 125 | ckfree(rwork); 126 | ckfree(work); 127 | /* A is also overwritten with junk */ 128 | Tcl_DecrRefCount(A); 129 | 130 | /* join U, s, V into a list*/ 131 | Tcl_Obj *result = Tcl_NewObj(); 132 | Tcl_ListObjAppendElement(NULL, result, U); 133 | Tcl_ListObjAppendElement(NULL, result, s); 134 | Tcl_ListObjAppendElement(NULL, result, V); 135 | Tcl_SetObjResult(interp, result); 136 | return TCL_OK; 137 | } 138 | } 139 | 140 | int Lsvd_Init(Tcl_Interp *interp) { 141 | if (interp == 0) return TCL_ERROR; 142 | 143 | if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { 144 | return TCL_ERROR; 145 | } 146 | 147 | if (Tcl_PkgRequire(interp, "vectcl", "0.1", 0) == NULL) { 148 | return TCL_ERROR; 149 | } 150 | 151 | if (Vectcl_InitStubs(interp, "0.1", 0) == NULL) { 152 | return TCL_ERROR; 153 | } 154 | 155 | Tcl_CreateObjCommand(interp, "lsvd", LapackSVDCmd, NULL, NULL); 156 | 157 | Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION); 158 | 159 | return TCL_OK; 160 | } 161 | -------------------------------------------------------------------------------- /APIdemo/pkgIndex.tcl.in: -------------------------------------------------------------------------------- 1 | # 2 | # Tcl package index file 3 | # 4 | package ifneeded @PACKAGE_NAME@ @PACKAGE_VERSION@ \ 5 | [list load [file join $dir @PKG_LIB_FILE@] @PACKAGE_NAME@] 6 | -------------------------------------------------------------------------------- /APIdemo/tclconfig/README.txt: -------------------------------------------------------------------------------- 1 | These files comprise the basic building blocks for a Tcl Extension 2 | Architecture (TEA) extension. For more information on TEA see: 3 | 4 | http://www.tcl.tk/doc/tea/ 5 | 6 | This package is part of the Tcl project at SourceForge, and latest 7 | sources should be available there: 8 | 9 | http://tcl.sourceforge.net/ 10 | 11 | This package is a freely available open source package. You can do 12 | virtually anything you like with it, such as modifying it, redistributing 13 | it, and selling it either in whole or in part. 14 | 15 | CONTENTS 16 | ======== 17 | The following is a short description of the files you will find in 18 | the sample extension. 19 | 20 | README.txt This file 21 | 22 | install-sh Program used for copying binaries and script files 23 | to their install locations. 24 | 25 | tcl.m4 Collection of Tcl autoconf macros. Included by a package's 26 | aclocal.m4 to define TEA_* macros. 27 | -------------------------------------------------------------------------------- /APIdemo/win/sample.rc: -------------------------------------------------------------------------------- 1 | // sample.rc - Copyright (C) 2006 Pat Thoyts 2 | // 3 | // There is no need to modify this file. 4 | // 5 | 6 | #include 7 | 8 | VS_VERSION_INFO VERSIONINFO 9 | FILEVERSION COMMAVERSION 10 | PRODUCTVERSION COMMAVERSION 11 | FILEFLAGSMASK 0x3fL 12 | #ifdef DEBUG 13 | FILEFLAGS VS_FF_DEBUG 14 | #else 15 | FILEFLAGS 0x0L 16 | #endif 17 | FILEOS VOS__WINDOWS32 18 | FILETYPE VFT_DLL 19 | FILESUBTYPE 0x0L 20 | BEGIN 21 | BLOCK "StringFileInfo" 22 | BEGIN 23 | BLOCK "040904b0" 24 | BEGIN 25 | VALUE "FileDescription", "Tcl Sample Extension " DOTVERSION "\0" 26 | VALUE "OriginalFilename", "sample" VERSION ".dll\0" 27 | VALUE "CompanyName", "The Tcl Development Community\0" 28 | VALUE "FileVersion", DOTVERSION "\0" 29 | VALUE "LegalCopyright", "Copyright \251 1999 Scriptics Corp.\0" 30 | VALUE "ProductName", "Tcl Sample Extension " DOTVERSION "\0" 31 | VALUE "ProductVersion", DOTVERSION "\0" 32 | END 33 | END 34 | BLOCK "VarFileInfo" 35 | BEGIN 36 | VALUE "Translation", 0x409, 1200 37 | END 38 | END 39 | -------------------------------------------------------------------------------- /LICENSES/COPYRIGHT.f2c: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software 5 | and its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of AT&T, Bell Laboratories, 10 | Lucent or Bellcore or any of their entities not be used in 11 | advertising or publicity pertaining to distribution of the 12 | software without specific, written prior permission. 13 | 14 | AT&T, Lucent and Bellcore disclaim all warranties with regard to 15 | this software, including all implied warranties of 16 | merchantability and fitness. In no event shall AT&T, Lucent or 17 | Bellcore be liable for any special, indirect or consequential 18 | damages or any damages whatsoever resulting from loss of use, 19 | data or profits, whether in an action of contract, negligence or 20 | other tortious action, arising out of or in connection with the 21 | use or performance of this software. 22 | ****************************************************************/ 23 | 24 | -------------------------------------------------------------------------------- /LICENSES/COPYRIGHT.hsfft: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Rafat Hussain 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. 9 | 10 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /LICENSES/COPYRIGHT.lapack: -------------------------------------------------------------------------------- 1 | Copyright (c) 1992-2008 The University of Tennessee. All rights reserved. 2 | 3 | $COPYRIGHT$ 4 | 5 | Additional copyrights may follow 6 | 7 | $HEADER$ 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are 11 | met: 12 | 13 | - Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | - Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer listed 18 | in this license in the documentation and/or other materials 19 | provided with the distribution. 20 | 21 | - Neither the name of the copyright holders nor the names of its 22 | contributors may be used to endorse or promote products derived from 23 | this software without specific prior written permission. 24 | 25 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 26 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 27 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 28 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 29 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 30 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 31 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 32 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 33 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 34 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 35 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 36 | 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | VecTcl 2 | ===== 3 | 4 | A numerical array extension for Tcl 5 | 6 | This package provides a numerical array extension for Tcl with support for 7 | vectors, matrices and higher-rank tensors of integers, floating point and 8 | complex numbers. It has builtin support for basic array shaping, slicing and 9 | linear algebra subroutines and is designed to integrate seamlessly with Tcl. The 10 | user interface consists of a single command, `vexpr`, which acts as an expression 11 | evaluator similar to `expr`. The language supported by `vexpr` is inspired by 12 | Matlab, which closely models the language used by textbook math. 13 | 14 | Example: 15 | 16 | package require vectcl 17 | namespace import vectcl::vexpr 18 | # create a vector and multiply by 3 19 | set x {1 2 3} 20 | set y [vexpr {3*x}] 21 | # y is now {3 6 9} 22 | 23 | For further documentation, see [the home page on GitHub pages](http://auriocus.github.io/VecTcl/) 24 | -------------------------------------------------------------------------------- /TkBridge/aclocal.m4: -------------------------------------------------------------------------------- 1 | # 2 | # Include the TEA standard macro set 3 | # 4 | 5 | builtin(include,tclconfig/tcl.m4) 6 | 7 | # 8 | # Add here whatever m4 macros you want to define for your package 9 | # 10 | -------------------------------------------------------------------------------- /TkBridge/generic/vectk.c: -------------------------------------------------------------------------------- 1 | /* Bridge between Tk photo and numarray 2 | */ 3 | #include 4 | #include 5 | #include 6 | #define MAX(x, y) ((x)>(y)?x:y) 7 | #define MIN(x, y) ((x)<(y)?x:y) 8 | 9 | typedef unsigned char sample; 10 | const sample maxval=0xFF; 11 | 12 | inline sample 13 | real2sample(const double value) { 14 | if (value >=(1.0-0.5/maxval)) return maxval; 15 | if (value <=0.0) return (sample)(0); 16 | return (sample)(maxval*value+0.5); 17 | } 18 | 19 | inline double sample2real(const sample v) { 20 | return ((double)(v))/((double)maxval); 21 | } 22 | 23 | int Photo2NumArrayCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { 24 | if (objc != 2) { 25 | Tcl_WrongNumArgs(interp, 1, objv, "photo"); 26 | return TCL_ERROR; 27 | } 28 | 29 | Tk_PhotoHandle source = Tk_FindPhoto (interp, Tcl_GetString(objv[1])); 30 | Tk_PhotoImageBlock sourceblock; 31 | Tk_PhotoGetImage(source, &sourceblock); 32 | int width=sourceblock.width; 33 | int height=sourceblock.height; 34 | int pitch=sourceblock.pitch; 35 | int pixelSize=sourceblock.pixelSize; 36 | int depth = 4; /* strange sourceblock.depth; */ 37 | 38 | 39 | if ((depth != 1) && (depth != 3) && (depth != 4)) { 40 | Tcl_SetResult(interp, "Grayscale, RGB or RGBA photo expected. WTF is this?", NULL); 41 | return TCL_ERROR; 42 | } 43 | 44 | Tcl_Obj *matrix; 45 | 46 | if (depth == 1) { 47 | /* Grayscale. Alloc 2D object */ 48 | matrix=NumArrayNewMatrix(NumArray_Float64, height, width); 49 | double *mPtr=NumArrayGetPtrFromObj(interp, matrix); 50 | /* copy the data */ 51 | index_t offs = sourceblock.offset[0]; 52 | sample *sPtr = sourceblock.pixelPtr + offs; 53 | index_t i,j; 54 | for (i=0; ibufsize); 70 | NumArraySetInternalRep(matrix, sharedbuf, info); 71 | 72 | double *mPtr = NumArrayGetPtrFromObj(interp, matrix); 73 | /* copy the data */ 74 | sample *sPtr = sourceblock.pixelPtr; 75 | int i,j,d; 76 | for (i=0; inDim != 3 && info->nDim != 2) { 105 | Tcl_SetResult(interp, "2D (grayscale) or 3D (color) matrix expected", NULL); 106 | return TCL_ERROR; 107 | } 108 | 109 | if (info->type != NumArray_Float64) { 110 | Tcl_SetResult(interp, "floating point data expected", NULL); 111 | return TCL_ERROR; 112 | } 113 | 114 | index_t height = info->dims[0]; 115 | index_t width = info->dims[1]; 116 | int depth = 1; /* grayscale */ 117 | 118 | index_t hpitch=info->pitches[0] / sizeof(double); 119 | index_t wpitch=info->pitches[1] / sizeof(double); 120 | index_t dpitch=0; 121 | 122 | if (info->nDim == 3) { 123 | depth = info->dims[2]; 124 | dpitch = info->pitches[2] / sizeof(double); 125 | if (depth != 3 && depth != 4) { 126 | Tcl_SetResult(interp, "3 (RBG) or 4 (RGBA) color planes expected", NULL); 127 | return TCL_ERROR; 128 | } 129 | } 130 | 131 | /* now get a handle to the target photo image */ 132 | 133 | Tk_PhotoHandle target = Tk_FindPhoto (interp, Tcl_GetString(objv[2])); 134 | if (target==NULL) { 135 | Tcl_SetResult(interp, "Cannot find image", NULL); 136 | return TCL_ERROR; 137 | } 138 | 139 | Tk_PhotoImageBlock outputline; 140 | outputline.width=width; 141 | outputline.height=height; 142 | outputline.pitch=width*depth; 143 | outputline.pixelSize=depth; 144 | 145 | outputline.pixelPtr=ckalloc(width*height*depth); 146 | 147 | double *mPtr=NumArrayGetPtrFromObj(interp, matrix); 148 | 149 | switch (depth) { 150 | case 1: { 151 | /* grayscale */ 152 | index_t i,j,d; 153 | for (d=0; d<4; d++) { 154 | outputline.offset[d]=0; 155 | } 156 | 157 | sample *outptr = outputline.pixelPtr; 158 | /* copy loop over all pixels */ 159 | for (i=0; i 2 | // 3 | // There is no need to modify this file. 4 | // 5 | 6 | #include 7 | 8 | VS_VERSION_INFO VERSIONINFO 9 | FILEVERSION COMMAVERSION 10 | PRODUCTVERSION COMMAVERSION 11 | FILEFLAGSMASK 0x3fL 12 | #ifdef DEBUG 13 | FILEFLAGS VS_FF_DEBUG 14 | #else 15 | FILEFLAGS 0x0L 16 | #endif 17 | FILEOS VOS__WINDOWS32 18 | FILETYPE VFT_DLL 19 | FILESUBTYPE 0x0L 20 | BEGIN 21 | BLOCK "StringFileInfo" 22 | BEGIN 23 | BLOCK "040904b0" 24 | BEGIN 25 | VALUE "FileDescription", "Tcl Sample Extension " DOTVERSION "\0" 26 | VALUE "OriginalFilename", "sample" VERSION ".dll\0" 27 | VALUE "CompanyName", "The Tcl Development Community\0" 28 | VALUE "FileVersion", DOTVERSION "\0" 29 | VALUE "LegalCopyright", "Copyright \251 1999 Scriptics Corp.\0" 30 | VALUE "ProductName", "Tcl Sample Extension " DOTVERSION "\0" 31 | VALUE "ProductVersion", DOTVERSION "\0" 32 | END 33 | END 34 | BLOCK "VarFileInfo" 35 | BEGIN 36 | VALUE "Translation", 0x409, 1200 37 | END 38 | END 39 | -------------------------------------------------------------------------------- /WavReader/aclocal.m4: -------------------------------------------------------------------------------- 1 | # 2 | # Include the TEA standard macro set 3 | # 4 | 5 | builtin(include,tclconfig/tcl.m4) 6 | 7 | # 8 | # Add here whatever m4 macros you want to define for your package 9 | # 10 | -------------------------------------------------------------------------------- /WavReader/generic/wavreader.c: -------------------------------------------------------------------------------- 1 | /* Read a WAVE soundfile into numarray 2 | */ 3 | #include 4 | #include 5 | #include 6 | #include 7 | #define MAX(x, y) ((x)>(y)?x:y) 8 | #define MIN(x, y) ((x)<(y)?x:y) 9 | 10 | enum WavChunks { 11 | RiffHeader = 0x46464952, 12 | WavRiff = 0x54651475, 13 | Format = 0x020746d66, 14 | LabeledText = 0x478747C6, 15 | Instrumentation = 0x478747C6, 16 | Sample = 0x6C706D73, 17 | Fact = 0x47361666, 18 | Data = 0x61746164, 19 | Junk = 0x4b4e554a, 20 | }; 21 | 22 | enum WavFormat { 23 | PulseCodeModulation = 0x01, 24 | IEEEFloatingPoint = 0x03, 25 | ALaw = 0x06, 26 | MuLaw = 0x07, 27 | IMAADPCM = 0x11, 28 | YamahaITUG723ADPCM = 0x16, 29 | GSM610 = 0x31, 30 | ITUG721ADPCM = 0x40, 31 | MPEG = 0x50, 32 | Extensible = 0xFFFE 33 | }; 34 | 35 | #if 0 36 | int32 chunkid = 0; 37 | bool datachunk = false; 38 | while ( !datachunk ) { 39 | chunkid = reader.ReadInt32( ); 40 | switch ( (WavChunks)chunkid ) { 41 | case WavChunks::Format: 42 | formatsize = reader.ReadInt32( ); 43 | format = (WavFormat)reader.ReadInt16( ); 44 | channels = (Channels)reader.ReadInt16( ); 45 | channelcount = (int)channels; 46 | samplerate = reader.ReadInt32( ); 47 | bitspersecond = reader.ReadInt32( ); 48 | formatblockalign = reader.ReadInt16( ); 49 | bitdepth = reader.ReadInt16( ); 50 | if ( formatsize == 18 ) { 51 | int32 extradata = reader.ReadInt16( ); 52 | reader.Seek( extradata, SeekOrigin::Current ); 53 | } 54 | break; 55 | case WavChunks::RiffHeader: 56 | headerid = chunkid; 57 | memsize = reader.ReadInt32( ); 58 | riffstyle = reader.ReadInt32( ); 59 | break; 60 | case WavChunks::Data: 61 | datachunk = true; 62 | datasize = reader.ReadInt32( ); 63 | break; 64 | default: 65 | int32 skipsize = reader.ReadInt32( ); 66 | reader.Seek( skipsize, SeekOrigin::Current ); 67 | break; 68 | } 69 | } 70 | #endif 71 | 72 | #define STHROW(X) { Tcl_SetResult(interp, X, TCL_VOLATILE); return TCL_ERROR; } 73 | #define READSCALAR(X) \ 74 | if (fread(&X, sizeof(X),1,wfile) < 1) {\ 75 | STHROW("Unexpected EOF");\ 76 | } 77 | 78 | /* for doing blocked read of a large file */ 79 | #define BLOCKSIZE 1048576 /* 1 MSample */ 80 | 81 | int ReadWavCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { 82 | if (objc != 2) { 83 | Tcl_WrongNumArgs(interp, 1, objv, ""); 84 | return TCL_ERROR; 85 | } 86 | 87 | /* open the file */ 88 | FILE* wfile = fopen(Tcl_GetString(objv[1]), "rb"); 89 | if (wfile == NULL) { 90 | STHROW("Couldn't open file"); 91 | } 92 | 93 | int32_t chunkid = 0; 94 | int datachunk = 0; 95 | int32_t formatsize; 96 | int16_t format; 97 | int16_t channels; 98 | int32_t samplerate; 99 | int32_t bitspersecond; 100 | int16_t formatblockalign; 101 | int16_t bitdepth; 102 | int32_t memsize; 103 | int32_t riffstyle; 104 | int32_t datasize; 105 | 106 | while ( !datachunk ) { 107 | READSCALAR(chunkid); 108 | 109 | switch ( chunkid ) { 110 | case Format: 111 | READSCALAR(formatsize); 112 | READSCALAR(format); 113 | READSCALAR(channels); 114 | READSCALAR(samplerate); 115 | READSCALAR(bitspersecond); 116 | READSCALAR(formatblockalign); 117 | READSCALAR(bitdepth); 118 | 119 | if ( formatsize == 18 ) { 120 | int16_t extradata; 121 | READSCALAR(extradata); 122 | fseek(wfile, extradata, SEEK_CUR); 123 | } 124 | break; 125 | case RiffHeader: 126 | READSCALAR(memsize); 127 | READSCALAR(riffstyle); 128 | break; 129 | case Data: 130 | datachunk = 1; 131 | READSCALAR(datasize); 132 | break; 133 | default: { 134 | int32_t skipsize; READSCALAR(skipsize); 135 | fseek(wfile, skipsize, SEEK_CUR); 136 | break; 137 | } 138 | } 139 | } 140 | 141 | if (format != PulseCodeModulation) { 142 | fclose(wfile); 143 | STHROW("Can only handle PCM data"); 144 | } 145 | 146 | size_t samplesize = bitdepth/8*channels; 147 | size_t buffersize = BLOCKSIZE*samplesize; 148 | int16_t *samples=ckalloc(buffersize); 149 | size_t nsamples = datasize/samplesize; 150 | double smaxval = 1<<(bitdepth-1); 151 | 152 | /* Alloc double matrix */ 153 | Tcl_Obj *matrix; 154 | if (channels==1 ) { 155 | matrix = NumArrayNewVector(NumArray_Float64, nsamples); 156 | } else { 157 | matrix = NumArrayNewMatrix(NumArray_Float64, nsamples, channels); 158 | } 159 | double *mPtr=NumArrayGetPtrFromObj(interp, matrix); 160 | 161 | ssize_t samplesleft; 162 | for (samplesleft=nsamples; samplesleft > 0; ) { 163 | ssize_t expected_samples = BLOCKSIZE; 164 | if (expected_samples > samplesleft) { 165 | expected_samples = samplesleft; 166 | } 167 | 168 | ssize_t samplesread = fread(samples, samplesize, expected_samples, wfile); 169 | 170 | if (samplesread < expected_samples) { 171 | /* file was truncated */ 172 | Tcl_SetObjResult(interp, Tcl_ObjPrintf("channels=%d, bitdepth=%d,datasize=%d,samplerate=%d,expected_samples=%d samplesread=%d", 173 | channels, bitdepth, datasize, samplerate, expected_samples, samplesread)); 174 | 175 | 176 | /*STHROW("Unexpected EOF reading the data"); */ 177 | return TCL_ERROR; 178 | } 179 | 180 | samplesleft -= samplesread; 181 | 182 | size_t i; 183 | for (i=0; i max { 64 | max = crosscorr 65 | maxind=i 66 | } 67 | } 68 | } 69 | 70 | 71 | fileutil::writeFile crosscorr.dat [join $corrdata \n] 72 | 73 | puts "Offset: [expr {$maxind*0.02}] s" 74 | puts "Length: [vexpr {rows(vid1data)*0.02}]" 75 | -------------------------------------------------------------------------------- /WavReader/win/sample.rc: -------------------------------------------------------------------------------- 1 | // sample.rc - Copyright (C) 2006 Pat Thoyts 2 | // 3 | // There is no need to modify this file. 4 | // 5 | 6 | #include 7 | 8 | VS_VERSION_INFO VERSIONINFO 9 | FILEVERSION COMMAVERSION 10 | PRODUCTVERSION COMMAVERSION 11 | FILEFLAGSMASK 0x3fL 12 | #ifdef DEBUG 13 | FILEFLAGS VS_FF_DEBUG 14 | #else 15 | FILEFLAGS 0x0L 16 | #endif 17 | FILEOS VOS__WINDOWS32 18 | FILETYPE VFT_DLL 19 | FILESUBTYPE 0x0L 20 | BEGIN 21 | BLOCK "StringFileInfo" 22 | BEGIN 23 | BLOCK "040904b0" 24 | BEGIN 25 | VALUE "FileDescription", "Tcl Sample Extension " DOTVERSION "\0" 26 | VALUE "OriginalFilename", "sample" VERSION ".dll\0" 27 | VALUE "CompanyName", "The Tcl Development Community\0" 28 | VALUE "FileVersion", DOTVERSION "\0" 29 | VALUE "LegalCopyright", "Copyright \251 1999 Scriptics Corp.\0" 30 | VALUE "ProductName", "Tcl Sample Extension " DOTVERSION "\0" 31 | VALUE "ProductVersion", DOTVERSION "\0" 32 | END 33 | END 34 | BLOCK "VarFileInfo" 35 | BEGIN 36 | VALUE "Translation", 0x409, 1200 37 | END 38 | END 39 | -------------------------------------------------------------------------------- /aclocal.m4: -------------------------------------------------------------------------------- 1 | # 2 | # Include the TEA standard macro set 3 | # 4 | 5 | builtin(include,tclconfig/tcl.m4) 6 | 7 | # 8 | # Add here whatever m4 macros you want to define for your package 9 | # 10 | -------------------------------------------------------------------------------- /benchmark/bench_comp.gnuplot: -------------------------------------------------------------------------------- 1 | #!/opt/local/bin/gnuplot -persist 2 | # 3 | # 4 | # G N U P L O T 5 | # Version 4.4 patchlevel 4 6 | # last modified November 2011 7 | # System: Darwin 12.5.0 8 | # 9 | # Copyright (C) 1986-1993, 1998, 2004, 2007-2011 10 | # Thomas Williams, Colin Kelley and many others 11 | # 12 | # gnuplot home: http://www.gnuplot.info 13 | # faq, bugs, etc: type "help seeking-assistance" 14 | # immediate help: type "help" 15 | # plot window: hit 'h' 16 | # set terminal x11 nopersist 17 | # set output 18 | unset clip points 19 | set clip one 20 | unset clip two 21 | set bar 1.000000 front 22 | set border 31 front linetype -1 linewidth 1.000 23 | set xdata 24 | set ydata 25 | set zdata 26 | set x2data 27 | set y2data 28 | set timefmt x "%d/%m/%y,%H:%M" 29 | set timefmt y "%d/%m/%y,%H:%M" 30 | set timefmt z "%d/%m/%y,%H:%M" 31 | set timefmt x2 "%d/%m/%y,%H:%M" 32 | set timefmt y2 "%d/%m/%y,%H:%M" 33 | set timefmt cb "%d/%m/%y,%H:%M" 34 | set boxwidth 35 | set style fill empty border 36 | set style rectangle back fc lt -3 fillstyle solid 1.00 border lt -1 37 | set style circle radius graph 0.02, first 0, 0 38 | set dummy x,y 39 | set format x "% g" 40 | set format y "% g" 41 | set format x2 "% g" 42 | set format y2 "% g" 43 | set format z "% g" 44 | set format cb "% g" 45 | set angles radians 46 | unset grid 47 | set key title "" 48 | set key inside right top vertical Right noreverse enhanced autotitles nobox 49 | set key noinvert samplen 4 spacing 1 width 0 height 0 50 | set key maxcolumns 0 maxrows 0 51 | unset label 52 | unset arrow 53 | set style increment default 54 | unset style line 55 | unset style arrow 56 | set style histogram clustered gap 2 title offset character 0, 0, 0 57 | unset logscale 58 | set logscale x 10 59 | set logscale y 10 60 | set offsets 0, 0, 0, 0 61 | set pointsize 1 62 | set pointintervalbox 1 63 | set encoding default 64 | unset polar 65 | unset parametric 66 | unset decimalsign 67 | set view 60, 30, 1, 1 68 | set samples 100, 100 69 | set isosamples 10, 10 70 | set surface 71 | unset contour 72 | set clabel '%8.3g' 73 | set mapping cartesian 74 | set datafile separator whitespace 75 | unset hidden3d 76 | set cntrparam order 4 77 | set cntrparam linear 78 | set cntrparam levels auto 5 79 | set cntrparam points 5 80 | set size ratio 0 1,1 81 | set origin 0,0 82 | set style data points 83 | set style function lines 84 | set xzeroaxis linetype -2 linewidth 1.000 85 | set yzeroaxis linetype -2 linewidth 1.000 86 | set zzeroaxis linetype -2 linewidth 1.000 87 | set x2zeroaxis linetype -2 linewidth 1.000 88 | set y2zeroaxis linetype -2 linewidth 1.000 89 | set ticslevel 0.5 90 | set mxtics default 91 | set mytics default 92 | set mztics default 93 | set mx2tics default 94 | set my2tics default 95 | set mcbtics default 96 | set xtics border in scale 1,0.5 mirror norotate offset character 0, 0, 0 97 | set xtics autofreq norangelimit 98 | set ytics border in scale 1,0.5 mirror norotate offset character 0, 0, 0 99 | set ytics autofreq norangelimit 100 | set ztics border in scale 1,0.5 nomirror norotate offset character 0, 0, 0 101 | set ztics autofreq norangelimit 102 | set nox2tics 103 | set noy2tics 104 | set cbtics border in scale 1,0.5 mirror norotate offset character 0, 0, 0 105 | set cbtics autofreq norangelimit 106 | set title "Computation only" 107 | set title offset character 0, 0, 0 font "" norotate 108 | set timestamp bottom 109 | set timestamp "" 110 | set timestamp offset character 0, 0, 0 font "" norotate 111 | set rrange [ * : * ] noreverse nowriteback # (currently [8.98847e+307:-8.98847e+307] ) 112 | set trange [ * : * ] noreverse nowriteback # (currently [-5.00000:5.00000] ) 113 | set urange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] ) 114 | set vrange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] ) 115 | set xlabel "# datapoints" 116 | set xlabel offset character 0, 0, 0 font "" textcolor lt -1 norotate 117 | set x2label "" 118 | set x2label offset character 0, 0, 0 font "" textcolor lt -1 norotate 119 | set xrange [ * : * ] noreverse nowriteback # (currently [0.00000:6.00000] ) 120 | set x2range [ * : * ] noreverse nowriteback # (currently [0.698970:6.00000] ) 121 | set ylabel "Speed (Msamples/s)" 122 | set ylabel offset character 0, 0, 0 font "" textcolor lt -1 rotate by -270 123 | set y2label "" 124 | set y2label offset character 0, 0, 0 font "" textcolor lt -1 rotate by -270 125 | set yrange [ * : * ] noreverse nowriteback # (currently [-2.00000:2.00000] ) 126 | set y2range [ * : * ] noreverse nowriteback # (currently [-1.28164:1.50091] ) 127 | set zlabel "" 128 | set zlabel offset character 0, 0, 0 font "" textcolor lt -1 norotate 129 | set zrange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] ) 130 | set cblabel "" 131 | set cblabel offset character 0, 0, 0 font "" textcolor lt -1 rotate by -270 132 | set cbrange [ * : * ] noreverse nowriteback # (currently [8.98847e+307:-8.98847e+307] ) 133 | set zero 1e-08 134 | set lmargin -1 135 | set bmargin -1 136 | set rmargin -1 137 | set tmargin -1 138 | set locale "de_DE.UTF-8" 139 | set pm3d explicit at s 140 | set pm3d scansautomatic 141 | set pm3d interpolate 1,1 flush begin noftriangles nohidden3d corners2color mean 142 | set palette positive nops_allcF maxcolors 0 gamma 1.5 color model RGB 143 | set palette rgbformulae 7, 5, 15 144 | set colorbox default 145 | set colorbox vertical origin screen 0.9, 0.2, 0 size screen 0.05, 0.6, 0 front bdefault 146 | set loadpath 147 | set fontpath 148 | set fit noerrorvariables 149 | GNUTERM = "aqua" 150 | plot "benchresult-1395959022.dat" u 1:(1.0/$2) title "Tcl", "" u 1:(1.0/$4) title "BLT::vector", "" u 1:(1.0/$6) title "NAP", "" u 1:(1.0/$8) title "VecTcl" 151 | # EOF 152 | -------------------------------------------------------------------------------- /benchmark/bench_memcpy.tcl: -------------------------------------------------------------------------------- 1 | # benchmark numarray against the memory bandwidth limit 2 | set dir [file dirname [file dirname [info script]]] 3 | 4 | lappend auto_path $dir $dir/lib 5 | package require vectcl 6 | namespace import vectcl::vexpr 7 | 8 | proc compute_bandwidth {code rep} { 9 | upvar 1 A A 10 | upvar 1 B B 11 | upvar 1 memsize memsize 12 | 13 | set t [time $code $rep] 14 | 15 | set micros [lindex $t 0] 16 | set bw [expr {$memsize/1e9 / ($micros*1e-6)}] 17 | 18 | puts "[format %.3g $bw] GBytes/s ($t in $rep repetitions)" 19 | return $bw 20 | 21 | } 22 | 23 | proc bench_vec {vlength} { 24 | puts "Benchmarking vectors of length $vlength" 25 | # create two double vectors of size 100000 26 | vexpr {A=ones(vlength)+0.0; B=ones(vlength)+0.0} 27 | 28 | set rep [expr {50000000/$vlength}] 29 | run_bench $A $B $rep 30 | } 31 | 32 | proc bench_mat {M N} { 33 | puts "Benchmarking matrices of size $M x $N" 34 | # create two double vectors of size 100000 35 | vexpr {A=ones(M,N)+0.0; B=ones(M,N)+0.0} 36 | 37 | set rep [expr {20000000/($M*$N)+1}] 38 | run_bench $A $B $rep 39 | } 40 | 41 | proc run_bench {A B rep} { 42 | set memsize [dict get [numarray info $A] bufsize] 43 | 44 | variable results 45 | set line $memsize 46 | 47 | puts "Memcopy: " 48 | lappend line [compute_bandwidth {numarray::fastcopy A $B} $rep] 49 | 50 | puts "Addition in C loop" 51 | lappend line [compute_bandwidth {numarray::fastadd A $B} $rep] 52 | 53 | # puts "Result should be 1001: [numarray get $A 23]" 54 | 55 | puts "Reduction" 56 | lappend line [compute_bandwidth {numarray::sum $B} $rep] 57 | 58 | puts "Assignment via iterators" 59 | lappend line [compute_bandwidth {numarray::= A $B} $rep] 60 | 61 | puts "Addition via iterators" 62 | lappend line [compute_bandwidth {numarray::+= A $B} $rep] 63 | 64 | puts "Unary operator" 65 | lappend line [compute_bandwidth {numarray::neg $B} $rep] 66 | 67 | puts "Binary operator" 68 | lappend line [compute_bandwidth {numarray::+ $A $B} $rep] 69 | 70 | lappend results $line 71 | # puts "Result should be 1001: [numarray get $A 23]" 72 | puts "" 73 | } 74 | 75 | set benchdir [file dirname [file dirname [info script]]] 76 | set fd [open [file join $benchdir benchmark benchmemcpy-[clock scan now].dat] w] 77 | fconfigure $fd -buffering line 78 | # vectors 79 | set results {} 80 | foreach s {10 20 50 100 200 500 1000 2000 5000 10000 20000 50000 100000 200000 500000 1000000} { 81 | bench_vec $s 82 | } 83 | puts $fd "# Vectors" 84 | puts $fd [join $results \n] 85 | puts $fd "\n" 86 | 87 | set results {} 88 | foreach s {2 5 10 20 50 100 200 500 1000 2000} { 89 | # square matrices 90 | bench_mat $s $s 91 | } 92 | 93 | puts $fd "# Square matrices N x N" 94 | puts $fd [join $results \n] 95 | puts $fd "\n" 96 | 97 | set results {} 98 | foreach N {5 10 20 50 100 200 500 1000 2000 5000 10000 20000 50000 100000 200000 500000} { 99 | # wide matrices 2 x N 100 | bench_mat 2 $N 101 | } 102 | 103 | puts $fd "# Wide matrices 2 x N" 104 | puts $fd [join $results \n] 105 | puts $fd "\n" 106 | 107 | set results {} 108 | foreach N {5 10 20 50 100 200 500 1000 2000 5000 10000 20000 50000 100000 200000 500000} { 109 | # tall matrices N x 2 110 | bench_mat $N 2 111 | } 112 | 113 | puts $fd "# Tall matrices N x 2" 114 | puts $fd [join $results \n] 115 | puts $fd "\n" 116 | 117 | close $fd 118 | -------------------------------------------------------------------------------- /benchmark/bench_setup.gnuplot: -------------------------------------------------------------------------------- 1 | #!/opt/local/bin/gnuplot -persist 2 | # 3 | # 4 | # G N U P L O T 5 | # Version 4.4 patchlevel 4 6 | # last modified November 2011 7 | # System: Darwin 12.5.0 8 | # 9 | # Copyright (C) 1986-1993, 1998, 2004, 2007-2011 10 | # Thomas Williams, Colin Kelley and many others 11 | # 12 | # gnuplot home: http://www.gnuplot.info 13 | # faq, bugs, etc: type "help seeking-assistance" 14 | # immediate help: type "help" 15 | # plot window: hit 'h' 16 | # set terminal x11 nopersist 17 | # set output 18 | unset clip points 19 | set clip one 20 | unset clip two 21 | set bar 1.000000 front 22 | set border 31 front linetype -1 linewidth 1.000 23 | set xdata 24 | set ydata 25 | set zdata 26 | set x2data 27 | set y2data 28 | set timefmt x "%d/%m/%y,%H:%M" 29 | set timefmt y "%d/%m/%y,%H:%M" 30 | set timefmt z "%d/%m/%y,%H:%M" 31 | set timefmt x2 "%d/%m/%y,%H:%M" 32 | set timefmt y2 "%d/%m/%y,%H:%M" 33 | set timefmt cb "%d/%m/%y,%H:%M" 34 | set boxwidth 35 | set style fill empty border 36 | set style rectangle back fc lt -3 fillstyle solid 1.00 border lt -1 37 | set style circle radius graph 0.02, first 0, 0 38 | set dummy x,y 39 | set format x "% g" 40 | set format y "% g" 41 | set format x2 "% g" 42 | set format y2 "% g" 43 | set format z "% g" 44 | set format cb "% g" 45 | set angles radians 46 | unset grid 47 | set key title "" 48 | set key inside right top vertical Right noreverse enhanced autotitles nobox 49 | set key noinvert samplen 4 spacing 1 width 0 height 0 50 | set key maxcolumns 0 maxrows 0 51 | unset label 52 | unset arrow 53 | set style increment default 54 | unset style line 55 | unset style arrow 56 | set style histogram clustered gap 2 title offset character 0, 0, 0 57 | unset logscale 58 | set logscale x 10 59 | set logscale y 10 60 | set offsets 0, 0, 0, 0 61 | set pointsize 1 62 | set pointintervalbox 1 63 | set encoding default 64 | unset polar 65 | unset parametric 66 | unset decimalsign 67 | set view 60, 30, 1, 1 68 | set samples 100, 100 69 | set isosamples 10, 10 70 | set surface 71 | unset contour 72 | set clabel '%8.3g' 73 | set mapping cartesian 74 | set datafile separator whitespace 75 | unset hidden3d 76 | set cntrparam order 4 77 | set cntrparam linear 78 | set cntrparam levels auto 5 79 | set cntrparam points 5 80 | set size ratio 0 1,1 81 | set origin 0,0 82 | set style data points 83 | set style function lines 84 | set xzeroaxis linetype -2 linewidth 1.000 85 | set yzeroaxis linetype -2 linewidth 1.000 86 | set zzeroaxis linetype -2 linewidth 1.000 87 | set x2zeroaxis linetype -2 linewidth 1.000 88 | set y2zeroaxis linetype -2 linewidth 1.000 89 | set ticslevel 0.5 90 | set mxtics default 91 | set mytics default 92 | set mztics default 93 | set mx2tics default 94 | set my2tics default 95 | set mcbtics default 96 | set xtics border in scale 1,0.5 mirror norotate offset character 0, 0, 0 97 | set xtics autofreq norangelimit 98 | set ytics border in scale 1,0.5 mirror norotate offset character 0, 0, 0 99 | set ytics autofreq norangelimit 100 | set ztics border in scale 1,0.5 nomirror norotate offset character 0, 0, 0 101 | set ztics autofreq norangelimit 102 | set nox2tics 103 | set noy2tics 104 | set cbtics border in scale 1,0.5 mirror norotate offset character 0, 0, 0 105 | set cbtics autofreq norangelimit 106 | set title "Setup speed" 107 | set title offset character 0, 0, 0 font "" norotate 108 | set timestamp bottom 109 | set timestamp "" 110 | set timestamp offset character 0, 0, 0 font "" norotate 111 | set rrange [ * : * ] noreverse nowriteback # (currently [8.98847e+307:-8.98847e+307] ) 112 | set trange [ * : * ] noreverse nowriteback # (currently [-5.00000:5.00000] ) 113 | set urange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] ) 114 | set vrange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] ) 115 | set xlabel "# datapoints" 116 | set xlabel offset character 0, 0, 0 font "" textcolor lt -1 norotate 117 | set x2label "" 118 | set x2label offset character 0, 0, 0 font "" textcolor lt -1 norotate 119 | set xrange [ * : * ] noreverse nowriteback # (currently [0.00000:6.00000] ) 120 | set x2range [ * : * ] noreverse nowriteback # (currently [0.698970:6.00000] ) 121 | set ylabel "Speed (Msamples/s)" 122 | set ylabel offset character 0, 0, 0 font "" textcolor lt -1 rotate by -270 123 | set y2label "" 124 | set y2label offset character 0, 0, 0 font "" textcolor lt -1 rotate by -270 125 | set yrange [ * : * ] noreverse nowriteback # (currently [-2.00000:1.00000] ) 126 | set y2range [ * : * ] noreverse nowriteback # (currently [-1.38021:0.722162] ) 127 | set zlabel "" 128 | set zlabel offset character 0, 0, 0 font "" textcolor lt -1 norotate 129 | set zrange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] ) 130 | set cblabel "" 131 | set cblabel offset character 0, 0, 0 font "" textcolor lt -1 rotate by -270 132 | set cbrange [ * : * ] noreverse nowriteback # (currently [8.98847e+307:-8.98847e+307] ) 133 | set zero 1e-08 134 | set lmargin -1 135 | set bmargin -1 136 | set rmargin -1 137 | set tmargin -1 138 | set locale "de_DE.UTF-8" 139 | set pm3d explicit at s 140 | set pm3d scansautomatic 141 | set pm3d interpolate 1,1 flush begin noftriangles nohidden3d corners2color mean 142 | set palette positive nops_allcF maxcolors 0 gamma 1.5 color model RGB 143 | set palette rgbformulae 7, 5, 15 144 | set colorbox default 145 | set colorbox vertical origin screen 0.9, 0.2, 0 size screen 0.05, 0.6, 0 front bdefault 146 | set loadpath 147 | set fontpath 148 | set fit noerrorvariables 149 | GNUTERM = "aqua" 150 | plot "benchresult-1395959022.dat" u 1:(1.0/$2) title "Tcl", "" u 1:(1.0/$5) title "BLT::vector", "" u 1:(1.0/$7) title "NAP", "" u 1:(1.0/$9) title "VecTcl" 151 | # EOF 152 | -------------------------------------------------------------------------------- /benchmark/bench_solvesys.tcl: -------------------------------------------------------------------------------- 1 | # benchmark numarray against the memory bandwidth limit 2 | set dir [file dirname [file dirname [info script]]] 3 | 4 | lappend auto_path $dir $dir/lib 5 | package require vectcl 6 | namespace import vectcl::vexpr 7 | 8 | # benchmark linear regression formulae 9 | proc benchsolvesys {vlength} { 10 | puts "Number of datapoints: $vlength" 11 | puts "=============================" 12 | set A {} 13 | set y {} 14 | for {set i 0} {$i<$vlength} {incr i} { 15 | lappend y [expr {$i*3+rand()}] 16 | set line {} 17 | for {set j 0} {$j<$vlength} {incr j} { 18 | lappend line [expr {$i+rand()}] 19 | } 20 | lappend A $line 21 | } 22 | 23 | puts [numarray info $A] 24 | puts [numarray info $y] 25 | 26 | puts [time {vexpr {p=A \ y}}] 27 | puts "Difference: [vexpr {sum(((A*p-y)./y).^2)}]" 28 | } 29 | 30 | benchsolvesys 10 31 | benchsolvesys 10 32 | benchsolvesys 50 33 | benchsolvesys 100 34 | benchsolvesys 200 35 | benchsolvesys 500 36 | benchsolvesys 1000 37 | -------------------------------------------------------------------------------- /benchmark/vecfbench.tcl: -------------------------------------------------------------------------------- 1 | 2 | # vecpde.tcl -- 3 | # Solve a simple PDE problem: 4 | # A bar is heated on one side with the other side isolated 5 | # 6 | lappend auto_path . /usr/lib 7 | package require vectcl 8 | namespace import vectcl::* 9 | 10 | set compiler gfortran-mp-4.6 11 | set OPT {-march=core2 -O3} 12 | 13 | # The coefficients 14 | # 15 | vexpr { 16 | k = 1.0e-3 # m2/s - thermal conductivity 17 | deltt = 0.01 # s - time step 18 | deltx = 0.01 # m - size of grid cell 19 | 20 | alpha = k * deltt / deltx^2 21 | } 22 | 23 | proc report {i t0 t1 t2 t3 t4 t5} { 24 | puts [format "%10d%10.4f%10.4f%10.4f%10.4f%10.4f%10.4f" $i $t0 $t1 $t2 $t3 $t4 $t5] 25 | } 26 | 27 | 28 | # 29 | # Time loop 30 | 31 | # cut down function calls by eliminating constants 32 | # only local vars 33 | vproc diffusion {alpha ngrid} { 34 | temp = constfill(0.0,ngrid+1) 35 | dtemp = constfill(0.0,ngrid+1) 36 | 37 | temp[ngrid] = 1.0 # The right-hand boundary condition: constant temperature 38 | 39 | n1 = 1*ngrid/4 40 | n2 = 2*ngrid/4 41 | n3 = 3*ngrid/4 42 | n4 = 7*ngrid/8 43 | 44 | for i=0:100000-1 { 45 | #dtemp[1:ngrid-1] = alpha * (temp[0:ngrid-2] + temp[2:ngrid] - 2.0 * temp[1:ngrid-1]) 46 | #temp = temp + dtemp 47 | 48 | # do an in-place update instead 49 | temp[1:-2] += alpha * (temp[0:-3] + temp[2:-1] - 2.0 * temp[1:-2]) 50 | 51 | # Boundary condition on the left side: zero flux 52 | 53 | temp[0] = temp[1] 54 | 55 | if i%5000 == 0 { 56 | temp_0 = temp[1] 57 | temp_1 = temp[n1] 58 | temp_2 = temp[n2] 59 | temp_3 = temp[n3] 60 | temp_4 = temp[n4] 61 | temp_5 = temp[-2] 62 | 63 | #report(i,temp_0,temp_1,temp_2,temp_3,temp_4,temp_5) 64 | } 65 | } 66 | } 67 | 68 | proc diffusion_fortran {ngrid} { 69 | set fd [open temp.f90 w] 70 | puts $fd [subst -nocommands { 71 | 72 | ! pde.f90 -- 73 | ! Quick and dirty implementation of the PDE problem shown in vecpde.tcl using Fortran 74 | ! 75 | program vecpde 76 | implicit none 77 | 78 | integer, parameter :: dp = kind(1.0d0) ! Make it all double-precision 79 | integer, parameter :: ngrid = $ngrid 80 | real(kind=dp), dimension(ngrid+1) :: temp 81 | real(kind=dp), dimension(ngrid+1) :: dtemp 82 | real(kind=dp) :: k, deltt, deltx, alpha 83 | real(kind=dp) :: temp_0, temp_1, temp_2, temp_3, temp_4, temp_5 84 | integer :: i 85 | 86 | integer :: count, count_rate, start 87 | 88 | ! 89 | ! Initialisation 90 | ! 91 | k = 1.0e-3_dp ! m2/s 92 | deltt = 0.01_dp ! m 93 | deltx = 0.01_dp ! s 94 | 95 | alpha = k * deltt / deltx ** 2 96 | 97 | temp = 0.0_dp 98 | dtemp = 0.0_dp 99 | 100 | ! 101 | ! Boundary condition 102 | ! 103 | temp(ngrid+1) = 1.0_dp 104 | 105 | call system_clock( start, count_rate ) 106 | 107 | do i = 1,100000 108 | dtemp(2:ngrid) = alpha * ( temp(1:ngrid-1) + temp(3:ngrid+1) - 2.0_dp * temp(2:ngrid) ) 109 | temp = temp + dtemp 110 | 111 | ! Boundary condition on the left: zero flux 112 | temp(1) = temp(2) 113 | 114 | ! Slightly different locations because of start at 1 instead of 0 115 | 116 | temp_0 = temp(2) 117 | temp_1 = temp(1*ngrid/4) 118 | temp_2 = temp(2*ngrid/4) 119 | temp_3 = temp(3*ngrid/4) 120 | temp_4 = temp(7*ngrid/8) 121 | temp_5 = temp(ngrid-2) 122 | 123 | if ( mod(i, 5000) == 1 ) then 124 | write(*,'(i10,6f10.4)') i, temp_0, temp_1, temp_2, temp_3, temp_4, temp_5 125 | endif 126 | enddo 127 | 128 | call system_clock( count, count_rate ) 129 | 130 | write(*,*) 'Time: ', dble(count-start)/count_rate 131 | end program 132 | 133 | }] 134 | close $fd 135 | 136 | exec $::compiler {*}$::OPT -o ./temp temp.f90 137 | set result [exec ./temp] 138 | # last number is the time in seconds w/o compilation and starting the process 139 | set s [lindex $result end] ;# very lazy, but works 140 | return [expr {$s*1e6}] ;# return microseconds 141 | } 142 | 143 | # run benchmark 144 | set gridsize {5 10 20 50 100 200 500 1000 2000 5000 10000} 145 | #set gridsize {5 10} 146 | foreach ngrid $gridsize { 147 | set t [time {diffusion $alpha $ngrid}] 148 | lappend tcl [lindex $t 0] ;# microseconds 149 | lappend fortran [diffusion_fortran $ngrid] 150 | } 151 | 152 | # output result 153 | set fd [open fbench.dat w] 154 | foreach t $tcl f $fortran n $gridsize { 155 | puts $fd "$n $t $f" 156 | } 157 | close $fd 158 | -------------------------------------------------------------------------------- /demo/3dcanvas.tcl: -------------------------------------------------------------------------------- 1 | package require Tk 2 | package require vectcl 3 | namespace import vectcl::* 4 | 5 | # this demonstration shows how to use VecTcl 6 | # to perform an orthogonal 3D transform on a set of points 7 | # and display it on a canvas. 8 | 9 | 10 | 11 | # define the coordinates for a cube with size 2 in the 12 | # center of the coordsys 13 | # each two coordinates are connected with a line 14 | # first top, then bottom, finally the 4 columns between 15 | # ceiling and bottom 16 | set cube { 17 | {1 -1 1} 18 | {1 1 1} 19 | {1 1 1} 20 | {-1 1 1} 21 | {-1 1 1} 22 | {-1 -1 1} 23 | {-1 -1 1} 24 | {1 -1 1} 25 | 26 | {1 -1 -1} 27 | {1 1 -1} 28 | {1 1 -1} 29 | {-1 1 -1} 30 | {-1 1 -1} 31 | {-1 -1 -1} 32 | {-1 -1 -1} 33 | {1 -1 -1} 34 | 35 | {1 -1 -1} 36 | {1 -1 1} 37 | {-1 -1 -1} 38 | {-1 -1 1} 39 | {-1 1 -1} 40 | {-1 1 1} 41 | {1 1 -1} 42 | {1 1 1} 43 | } 44 | 45 | vproc eulerx {phi} { 46 | list( \ 47 | list(1.0, 0.0, 0.0), \ 48 | list(0.0, cos(phi), sin(phi)), \ 49 | list(0.0, -sin(phi), cos(phi))) 50 | } 51 | 52 | vproc eulery {phi} { 53 | list( \ 54 | list(cos(phi), 0.0, sin(phi)), \ 55 | list(0.0, 1.0, 0.0), \ 56 | list(-sin(phi), 0.0, cos(phi))) 57 | } 58 | 59 | vproc eulerz {phi} { 60 | list( \ 61 | list(cos(phi), sin(phi), 0.0), \ 62 | list(-sin(phi), cos(phi), 0.0), \ 63 | list(0.0, 0.0, 1.0)) 64 | } 65 | 66 | vproc euler {phi chi psi} { 67 | # this function returns the 68 | # subsequent rotation around the axis x,y,z 69 | # with angles phi, chi, psi 70 | # it is slow, but only called once for every frame 71 | eulerz(psi)*eulery(chi)*eulerx(phi) 72 | } 73 | 74 | # create a canvas 75 | canvas .c -width 500 -height 500 76 | # four sliders 77 | ttk::scale .s -variable s -from 1.0 -to 250.0 -command updatePlot 78 | ttk::scale .phi -variable phi -from 0.0 -to 6.28 -command updatePlot 79 | ttk::scale .chi -variable chi -from 0.0 -to 6.28 -command updatePlot 80 | ttk::scale .psi -variable psi -from 0.0 -to 6.28 -command updatePlot 81 | 82 | set s 100.0 83 | set phi 0.5 84 | set chi 0.12 85 | set psi 0.0 86 | 87 | grid .s -sticky nsew 88 | grid .phi -sticky nsew 89 | grid .chi -sticky nsew 90 | grid .psi -sticky nsew 91 | grid .c -sticky nsew 92 | 93 | grid rowconfigure . 0 -weight 1 94 | grid columnconfigure . 0 -weight 1 95 | 96 | proc updatePlot {args} { 97 | .c delete all 98 | set width [winfo width .c] 99 | set height [winfo height .c] 100 | vexpr { 101 | T = euler(::phi, ::chi, ::psi) 102 | Tx = ::s*(T*::cube')' 103 | x = Tx[:, 0]+width/2 104 | y = -Tx[:, 1]+height/2 105 | } 106 | # create lines in the canvas 107 | foreach {x1 x2} $x {y1 y2} $y { 108 | .c create line [list $x1 $y1 $x2 $y2] 109 | } 110 | } 111 | 112 | update; # let the geometry propagate 113 | updatePlot 114 | -------------------------------------------------------------------------------- /demo/autodiff.tcl: -------------------------------------------------------------------------------- 1 | # simple example for using vexpr to do automatic differentation (AD) 2 | # AD is a technique to compute an expression alongside with it's 3 | # analytic derivative using the chainrule 4 | package require vectcl 5 | namespace import vectcl::* 6 | 7 | proc isAD {x} { expr {[lindex $x 0] eq "AD"} } 8 | 9 | proc mkAD {x dx} { list AD $x $dx } 10 | 11 | namespace eval ADeval { 12 | # the definition of an AD expression is 13 | # a list with AD, then x, then dx (only scalar for clarity) 14 | # also there is no forwarding to numarray 15 | proc dissectargs {args} { 16 | # result is pairwise, value and derivative 17 | set result {} 18 | foreach el $args { 19 | if {[isAD $el]} { 20 | lassign $el AD x dx 21 | lappend result $x $dx 22 | } else { 23 | lappend result $el 0 24 | } 25 | } 26 | return $result 27 | } 28 | 29 | proc + {e1 e2} { 30 | lassign [dissectargs $e1 $e2] x dx y dy 31 | mkAD [expr {$x+$y}] [expr {$dx+$dy}] 32 | } 33 | 34 | proc - {e1 e2} { 35 | lassign [dissectargs $e1 $e2] x dx y dy 36 | mkAD [expr {$x-$y}] [expr {$dx-$dy}] 37 | } 38 | 39 | proc / {e1 e2} { 40 | lassign [dissectargs $e1 $e2] x dx y dy 41 | mkAD [expr {$x/$y}] [expr {($dx*$y - $dy*$x)/($y*$y)}] 42 | } 43 | 44 | proc * {e1 e2} { 45 | lassign [dissectargs $e1 $e2] x dx y dy 46 | mkAD [expr {$x*$y}] [expr {$x*$dy+$dx*$y}] 47 | } 48 | 49 | proc exp {e} { 50 | lassign [dissectargs $e] x dx 51 | mkAD [expr {exp($x)}] [expr {exp($x)*$dx}] 52 | } 53 | 54 | proc sin {e} { 55 | lassign [dissectargs $e] x dx 56 | mkAD [expr {sin($x)}] [expr {cos($x)*$dx}] 57 | } 58 | 59 | proc cos {e} { 60 | lassign [dissectargs $e] x dx 61 | mkAD [expr {cos($x)}] [expr {-sin($x)*$dx}] 62 | } 63 | 64 | } 65 | 66 | # now inject into VecTcl by renaming the numarray procedures 67 | namespace eval savedops {} 68 | 69 | foreach op {+ - * / exp sin cos} { 70 | # this example throws away the numarray commands 71 | rename numarray::$op savedops::$op 72 | interp alias {} numarray::$op {} ADeval::$op 73 | } 74 | 75 | # test 76 | # dependent variable x 77 | set rx [expr {3.1415926535/6}] ;# 30° 78 | set x [mkAD $rx 1.0] 79 | 80 | puts [vexpr {sin(x)}] 81 | puts "f=[expr {sin($rx)}], df/dx = [expr {cos($rx)}]" 82 | 83 | # Arjens example 84 | set a -0.5 85 | foreach rx {0 1 2 3 4 5} { 86 | set x [mkAD $rx 1.0] 87 | puts "x=$rx" 88 | puts "Automatic: [vexpr {exp(a*x)}]" 89 | puts "Manual: [mkAD [expr {exp($a*$rx)}] [expr {$a*exp($a*$rx)}]]" 90 | 91 | puts "Automatic: [vexpr {2*sin(x)/cos(x)}]" 92 | puts "Manual: [mkAD [expr {2*sin($rx)/cos($rx)}] [expr {2.0/cos($rx)**2}]]" 93 | } 94 | 95 | 96 | -------------------------------------------------------------------------------- /demo/cube3d.tcl: -------------------------------------------------------------------------------- 1 | package require Tk 2 | package require vectcl 3 | namespace import vectcl::* 4 | 5 | # this demonstration shows how to use VecTcl 6 | # to perform an orthogonal 3D transform on a set of points 7 | # and display it on a canvas. 8 | 9 | set w .cube 10 | catch {destroy $w} 11 | toplevel $w 12 | 13 | # create random lines 14 | set data {} 15 | for {set i 0} {$i<1000} {incr i} { 16 | set r1 [expr {rand()-0.5}] 17 | set r2 [expr {rand()-0.5}] 18 | set r3 [expr {rand()-0.5}] 19 | lappend data [list $r1 $r2 $r3] 20 | } 21 | 22 | vproc eulerx {phi} { 23 | list( \ 24 | list(1.0, 0.0, 0.0), \ 25 | list(0.0, cos(phi), sin(phi)), \ 26 | list(0.0, -sin(phi), cos(phi))) 27 | } 28 | 29 | vproc eulery {phi} { 30 | list( \ 31 | list(cos(phi), 0.0, sin(phi)), \ 32 | list(0.0, 1.0, 0.0), \ 33 | list(-sin(phi), 0.0, cos(phi))) 34 | } 35 | 36 | vproc eulerz {phi} { 37 | list( \ 38 | list(cos(phi), sin(phi), 0.0), \ 39 | list(-sin(phi), cos(phi), 0.0), \ 40 | list(0.0, 0.0, 1.0)) 41 | } 42 | 43 | vproc euler {phi chi psi} { 44 | # this function returns the 45 | # subsequent rotation around the axis x,y,z 46 | # with angles phi, chi, psi 47 | # it is slow, but only called once for every frame 48 | eulerz(psi)*eulery(chi)*eulerx(phi) 49 | } 50 | 51 | # create a canvas 52 | canvas $w.c -width 500 -height 500 53 | # four sliders 54 | ttk::scale $w.s -variable s -from 10.0 -to 500.0 -command updatePlot 55 | ttk::scale $w.phi -variable phi -from 0.0 -to 6.28 -command updatePlot 56 | ttk::scale $w.chi -variable chi -from 0.0 -to 6.28 -command updatePlot 57 | ttk::scale $w.psi -variable psi -from 0.0 -to 6.28 -command updatePlot 58 | 59 | set s 300.0 60 | set phi 0.5 61 | set chi 0.12 62 | set psi 0.0 63 | 64 | grid $w.s -sticky nsew 65 | grid $w.phi -sticky nsew 66 | grid $w.chi -sticky nsew 67 | grid $w.psi -sticky nsew 68 | grid $w.c -sticky nsew 69 | 70 | grid rowconfigure $w 0 -weight 1 71 | grid columnconfigure $w 0 -weight 1 72 | 73 | 74 | proc updatePlot {args} { 75 | variable w 76 | set width [winfo width $w.c] 77 | set height [winfo height $w.c] 78 | 79 | lassign [do3DTransform $::data $width $height] x y 80 | 81 | $w.c delete all 82 | # create lines in the canvas - shimmers to list 83 | foreach {x1 x2} $x {y1 y2} $y { 84 | $w.c create line [list $x1 $y1 $x2 $y2] 85 | } 86 | } 87 | 88 | vproc do3DTransform {data width height} { 89 | T = euler(::phi, ::chi, ::psi) 90 | Tx = ::s*(T*::data')' 91 | x = Tx[:, 0]+width/2 92 | y = -Tx[:, 1]+height/2 93 | list(x,y) 94 | } 95 | 96 | update; # let the geometry propagate 97 | updatePlot 98 | -------------------------------------------------------------------------------- /demo/householder.tcl: -------------------------------------------------------------------------------- 1 | package require vectcl 2 | namespace import vectcl::* 3 | 4 | # computing Householder vector 5 | # Golub & Loan 5.1.1 6 | 7 | vproc house {x} { 8 | n=rows(x) 9 | if (n==1) { 10 | # a scalar. Just return 1 for v 11 | # and 0 for beta 12 | return(list(1.0,2.0)) 13 | } 14 | sigma=x[1:-1]'*x[1:-1] 15 | v=x; v[0]=1 16 | if sigma==0 { 17 | beta=0 18 | } else { 19 | mu = sqrt(x[0]^2+sigma) 20 | if x[0]<=0 { 21 | v[0]=x[0]-mu 22 | } else { 23 | v[0] = -sigma / (x[0]+mu) 24 | } 25 | beta = 2*v[0]^2 / (sigma+v[0]^2) 26 | v = v / v[0] 27 | } 28 | list(v, beta) 29 | } 30 | 31 | # computing Householder QR 32 | # Golub & Loan 5.2.1 33 | 34 | vproc houseQR {A} { 35 | m, n=shape(A) 36 | for j=0:n-1 { 37 | v, beta = house(A[j:-1, j]) 38 | # update can be done by subtracting 39 | w=beta*A[j:-1, j:n-1]'*v 40 | A[j:-1, j:n-1] -= v*w' 41 | if j toggleFit 23 | 24 | ## See Code / Dismiss buttons 25 | 26 | canvas $c -relief raised -width 450 -height 300 27 | pack $w.c -side top -fill x 28 | 29 | set plotFont {Helvetica 18} 30 | 31 | $c create line 100 250 400 250 -width 2 32 | $c create line 100 250 100 50 -width 2 33 | $c create line 100 250 100 50 -width 3 -fill {midnight blue} -tag regression 34 | $c create text 225 20 -text "A Simple Plot" -font $plotFont -fill brown 35 | 36 | for {set i 0} {$i <= 10} {incr i} { 37 | set x [expr {100 + ($i*30)}] 38 | $c create line $x 250 $x 245 -width 2 39 | $c create text $x 254 -text [expr {10*$i}] -anchor n -font $plotFont 40 | } 41 | for {set i 0} {$i <= 5} {incr i} { 42 | set y [expr {250 - ($i*40)}] 43 | $c create line 100 $y 105 $y -width 2 44 | $c create text 96 $y -text [expr {$i*50}].0 -anchor e -font $plotFont 45 | } 46 | 47 | foreach point { 48 | {12 56} {20 94} {33 98} {32 120} {61 180} {75 160} {98 223} 49 | } { 50 | set x [expr {100 + (3*[lindex $point 0])}] 51 | set y [expr {250 - (4*[lindex $point 1])/5}] 52 | set item [$c create oval [expr {$x-6}] [expr {$y-6}] \ 53 | [expr {$x+6}] [expr {$y+6}] -width 1 -outline black \ 54 | -fill SkyBlue2] 55 | $c addtag point withtag $item 56 | } 57 | 58 | $c bind point "$c itemconfig current -fill red" 59 | $c bind point "$c itemconfig current -fill SkyBlue2" 60 | $c bind point <1> "plotDown $c %x %y" 61 | $c bind point "$c dtag selected" 62 | bind $c "plotMove $c %x %y" 63 | 64 | set plot(lastX) 0 65 | set plot(lastY) 0 66 | 67 | # plotDown -- 68 | # This procedure is invoked when the mouse is pressed over one of the 69 | # data points. It sets up state to allow the point to be dragged. 70 | # 71 | # Arguments: 72 | # w - The canvas window. 73 | # x, y - The coordinates of the mouse press. 74 | 75 | proc plotDown {w x y} { 76 | global plot 77 | $w dtag selected 78 | $w addtag selected withtag current 79 | $w raise current 80 | set plot(lastX) $x 81 | set plot(lastY) $y 82 | } 83 | 84 | # plotMove -- 85 | # This procedure is invoked during mouse motion events. It drags the 86 | # current item. 87 | # 88 | # Arguments: 89 | # w - The canvas window. 90 | # x, y - The coordinates of the mouse. 91 | 92 | proc plotMove {w x y} { 93 | global plot 94 | $w move selected [expr {$x-$plot(lastX)}] [expr {$y-$plot(lastY)}] 95 | set plot(lastX) $x 96 | set plot(lastY) $y 97 | updateFit 98 | } 99 | 100 | interp alias {} updateFit {} updateFitLin 101 | 102 | proc updateFitLin {} { 103 | # retrieve current point coordinates from canvas 104 | # 105 | variable c 106 | foreach id [$c find withtag point] { 107 | lassign [$c coords $id] xc yc 108 | # xc and yc are coordinates of the upper left corner 109 | lappend x $xc 110 | lappend y $yc 111 | } 112 | 113 | vexpr { 114 | # compute coordinates of center 115 | x+=6; y+=6 116 | n = rows(x) 117 | A = hstack(1.0, x) ;# construct system matrix 118 | # first col is constant 119 | # second column x 120 | 121 | # solve equations 122 | p = A \ y 123 | 124 | # create coordinates for line 125 | xl = linspace(100,400,100) 126 | yl = p[0]+p[1]*xl 127 | } 128 | 129 | # create flat list for canvas 130 | set coords {} 131 | foreach x $xl y $yl { 132 | lappend coords $x $y 133 | } 134 | 135 | $c coords regression $coords 136 | } 137 | 138 | proc updateFitSqr {} { 139 | # retrieve current point coordinates from canvas 140 | # 141 | variable c 142 | foreach id [$c find withtag point] { 143 | lassign [$c coords $id] xc yc 144 | # xc and yc are coordinates of the upper left corner 145 | lappend x $xc 146 | lappend y $yc 147 | } 148 | vexpr { 149 | # compute coordinates of center 150 | x+=6; y+=6 151 | # construct system matrix 152 | # first col is constant 153 | # second column x 154 | # third column x² 155 | 156 | A = hstack(1.0, x, x.^2) 157 | # solve equations 158 | p = A \ y 159 | 160 | # create coordinates for line 161 | 162 | xl = linspace(100,400,100) 163 | yl = p[0]+p[1]*xl+p[2]*xl.^2 164 | } 165 | 166 | # create flat list for canvas 167 | set coords {} 168 | foreach x $xl y $yl { 169 | lappend coords $x $y 170 | } 171 | 172 | $c coords regression $coords 173 | } 174 | 175 | proc updateFitNop {} { 176 | variable c 177 | $c coords regression 100 250 100 50 178 | } 179 | 180 | proc toggleFit {} { 181 | set procs {updateFitLin updateFitSqr updateFitLin} 182 | set old [interp alias {} updateFit] 183 | while {[set procs [lassign $procs new]] ne ""} { 184 | if {$new eq $old} { 185 | lassign $procs new 186 | break 187 | } 188 | } 189 | interp alias {} updateFit {} $new 190 | updateFit 191 | } 192 | -------------------------------------------------------------------------------- /demo/somloi_galuska.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/auriocus/VecTcl/8cce67a4f4d54bcb67b601af6569d13407943d4d/demo/somloi_galuska.png -------------------------------------------------------------------------------- /generic/arrayshape.h: -------------------------------------------------------------------------------- 1 | #ifndef ARRAYSHAPE_H 2 | #define ARRAYSHAPE_H 3 | 4 | #include "vectclInt.h" 5 | SUBCOMMAND(NumArrayConcatCmd); 6 | SUBCOMMAND(NumArrayDiagCmd); 7 | 8 | int NumArrayDiagMatrix(Tcl_Interp *interp, Tcl_Obj *din, index_t diag, Tcl_Obj **dout); 9 | 10 | #endif 11 | -------------------------------------------------------------------------------- /generic/assignop.h: -------------------------------------------------------------------------------- 1 | /* to be included with CMD and OP defined 2 | * it defines an elementwise binary assignment operator 3 | * which works by iterating over all elements 4 | * for compatible operands */ 5 | #include "compathack.h" 6 | 7 | #ifndef ASSIGNOP_LOOP 8 | typedef int (assignop_loop_fun) (Tcl_Interp *interp, NumArraySharedBuffer *sharedbuf, NumArrayInfo *sliceinfo, Tcl_Obj *value); 9 | #define ASSIGNOP_LOOP_FUN(C, T1, T2) ASSIGNOP_LOOP_FUN1(C, T1, T2) 10 | #define ASSIGNOP_LOOP_FUN1(C, T1, T2) C##_loop_##T1##_##T2 11 | #define DECLARE_ASSIGNOP(T1, T2) static assignop_loop_fun ASSIGNOP_LOOP_FUN(CMD, T1, T2) 12 | #define ASSIGNOP_LOOP 13 | #endif 14 | 15 | #define LOOPTBL LOOPTABLE_IMP1(CMD) 16 | #define LOOPTABLE_IMP1(C) LOOPTABLE_IMP2(C) 17 | #define LOOPTABLE_IMP2(C) C##_table 18 | 19 | DECLARE_ASSIGNOP(NaWideInt, NaWideInt); 20 | DECLARE_ASSIGNOP(double, NaWideInt); 21 | DECLARE_ASSIGNOP(double, double); 22 | DECLARE_ASSIGNOP(NumArray_Complex, NaWideInt); 23 | DECLARE_ASSIGNOP(NumArray_Complex, double); 24 | DECLARE_ASSIGNOP(NumArray_Complex, NumArray_Complex); 25 | 26 | static assignop_loop_fun * LOOPTBL[3][3] = { 27 | { ASSIGNOP_LOOP_FUN(CMD, NaWideInt, NaWideInt), NULL, NULL}, 28 | { ASSIGNOP_LOOP_FUN(CMD, double, NaWideInt), ASSIGNOP_LOOP_FUN(CMD, double, double), NULL}, 29 | { ASSIGNOP_LOOP_FUN(CMD, NumArray_Complex, NaWideInt), ASSIGNOP_LOOP_FUN(CMD, NumArray_Complex, double), ASSIGNOP_LOOP_FUN(CMD, NumArray_Complex, NumArray_Complex)} 30 | }; 31 | 32 | 33 | int CMD( 34 | ClientData dummy, 35 | Tcl_Interp *interp, 36 | int objc, 37 | Tcl_Obj *const *objv) 38 | { 39 | Tcl_Obj *naObj, *value, *resultPtr; 40 | int allocobj = 0; int slicing = 0; 41 | 42 | NumArraySharedBuffer * sharedbuf; 43 | NumArrayInfo *info, *sliceinfo, *valueinfo; 44 | 45 | if (objc != 4 && objc != 3) { 46 | Tcl_WrongNumArgs(interp, 1, objv, "numarrayvar ?slicelist? numarray"); 47 | return TCL_ERROR; 48 | } 49 | 50 | if (objc==4) { 51 | /* slicing requested */ 52 | value = objv[3]; 53 | slicing = 1; 54 | } else { 55 | value = objv[2]; 56 | slicing = 0; 57 | } 58 | 59 | naObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); 60 | if (naObj == NULL) { 61 | return TCL_ERROR; 62 | } 63 | 64 | if (Tcl_ConvertToType(interp, naObj, &NumArrayTclType) != TCL_OK) { 65 | return TCL_ERROR; 66 | } 67 | 68 | if (Tcl_ConvertToType(interp, value, &NumArrayTclType) != TCL_OK) { 69 | return TCL_ERROR; 70 | } 71 | 72 | info = naObj -> internalRep.twoPtrValue.ptr2; 73 | valueinfo = value -> internalRep.twoPtrValue.ptr2; 74 | 75 | /* Check if upcasting is required. This may need 76 | * an out-of-place operation */ 77 | if (info -> type < valueinfo -> type) { 78 | Tcl_Obj *conv; 79 | if (NumArrayConvertToType(interp, naObj, valueinfo ->type, &conv) != TCL_OK) { 80 | return TCL_ERROR; 81 | } 82 | 83 | naObj = conv; 84 | 85 | } else { 86 | /* in-place - handle sharing */ 87 | if (Tcl_IsShared(naObj)) { 88 | naObj = Tcl_DuplicateObj(naObj); 89 | allocobj = 1; 90 | } 91 | 92 | NumArrayEnsureWriteable(naObj); 93 | } 94 | 95 | info = naObj -> internalRep.twoPtrValue.ptr2; 96 | sharedbuf = naObj -> internalRep.twoPtrValue.ptr1; 97 | 98 | /* handle slicing: create temporary sliceinfo */ 99 | if (slicing) { 100 | if (NumArrayInfoSlice(interp, info, objv[2], &sliceinfo) != TCL_OK) { 101 | goto cleanobj; 102 | } 103 | /* note - due to value (esp. literal) sharing it can happen that parsing the slice 104 | * shimmers value back to a different type. Therefore we must ensure that 105 | * value and naObj are numeric arrays. Perverse example: x[x] = x 106 | * naObj is never shared at this point */ 107 | 108 | if (Tcl_ConvertToType(interp, value, &NumArrayTclType) != TCL_OK) { 109 | /* if an error occurs here, there is a refcounting bug */ 110 | goto cleanobj; 111 | } 112 | valueinfo = value -> internalRep.twoPtrValue.ptr2; 113 | 114 | } else { 115 | /* No slicing. Take the full array */ 116 | sliceinfo = info; 117 | } 118 | 119 | /* Check if dimensions are compatible. Also holds if value is scalar */ 120 | if (!NumArrayCompatibleDimensions(sliceinfo, valueinfo) && !ISSCALARINFO(valueinfo)) { 121 | Tcl_SetResult(interp, "Dimension mismatch", NULL); 122 | goto cleaninfo; 123 | } 124 | 125 | /* map to int,double,complex - workaround 126 | * until we have the real implementation */ 127 | int ind1=NumArrayCompatTypeMap[sliceinfo->type]; 128 | int ind2=NumArrayCompatTypeMap[valueinfo->type]; 129 | if (ind1 < 0 || ind2 < 0) { 130 | Tcl_SetObjResult(interp, Tcl_ObjPrintf("Operator undefined for types %s, %s", NumArray_typename[sliceinfo->type], NumArray_typename[valueinfo->type])); 131 | goto cleaninfo; 132 | } 133 | 134 | 135 | if (LOOPTBL[ind1][ind2](interp, sharedbuf, sliceinfo, value)!=TCL_OK) { 136 | goto cleaninfo; 137 | } 138 | 139 | /* no error so far - discard temp sliceinfo, string rep and set variable and result */ 140 | if (slicing) DeleteNumArrayInfo(sliceinfo); 141 | Tcl_InvalidateStringRep(naObj); 142 | 143 | resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, naObj, TCL_LEAVE_ERR_MSG); 144 | if (resultPtr == NULL) { 145 | return TCL_ERROR; 146 | } 147 | Tcl_SetObjResult(interp, resultPtr); 148 | return TCL_OK; 149 | 150 | cleaninfo: 151 | if (slicing) DeleteNumArrayInfo(sliceinfo); 152 | cleanobj: 153 | if (allocobj) Tcl_DecrRefCount(naObj); 154 | return TCL_ERROR; 155 | } 156 | 157 | 158 | #define DEREFIT_NaWideInt NumArrayIteratorDeRefInt 159 | #define DEREFIT_double NumArrayIteratorDeRefDouble 160 | #define DEREFIT_NumArray_Complex NumArrayIteratorDeRefComplex 161 | 162 | #define GETOP_IMP1(T) DEREFIT_##T 163 | #define GETOP_IMP(T) GETOP_IMP1(T) 164 | 165 | #define GETOP UPCAST(T, TRES, GETOP_IMP(T)(&srcit)) 166 | 167 | 168 | #define TRES NaWideInt 169 | #define T NaWideInt 170 | #ifdef OPINT 171 | #define OP OPINT 172 | #endif 173 | #include "assignop_loop.h" 174 | 175 | 176 | #define TRES double 177 | #define T NaWideInt 178 | #ifdef OPDBL 179 | #define OP OPDBL 180 | #endif 181 | #include "assignop_loop.h" 182 | 183 | #define TRES double 184 | #define T double 185 | #ifdef OPDBL 186 | #define OP OPDBL 187 | #endif 188 | #include "assignop_loop.h" 189 | 190 | #define TRES NumArray_Complex 191 | #define T NaWideInt 192 | #ifdef OPCPLX 193 | #define OP OPCPLX 194 | #endif 195 | #include "assignop_loop.h" 196 | 197 | #define TRES NumArray_Complex 198 | #define T double 199 | #ifdef OPCPLX 200 | #define OP OPCPLX 201 | #endif 202 | #include "assignop_loop.h" 203 | 204 | #define TRES NumArray_Complex 205 | #define T NumArray_Complex 206 | #ifdef OPCPLX 207 | #define OP OPCPLX 208 | #endif 209 | #include "assignop_loop.h" 210 | 211 | #undef GETOP_IMP1 212 | #undef GETOP_IMP 213 | #undef GETOP 214 | 215 | #undef CMD 216 | #undef OPINT 217 | #undef OPDBL 218 | #undef OPCPLX 219 | -------------------------------------------------------------------------------- /generic/assignop_loop.h: -------------------------------------------------------------------------------- 1 | static int ASSIGNOP_LOOP_FUN(CMD, TRES, T) (Tcl_Interp *interp, NumArraySharedBuffer *sharedbuf, NumArrayInfo *sliceinfo, Tcl_Obj* value) { 2 | 3 | NumArrayInfo *valueinfo = value -> internalRep.twoPtrValue.ptr2; 4 | 5 | #ifndef OP 6 | RESULTPRINTF(("Assignment operator undefined for types %s, %s", NumArray_typename[sliceinfo->type], NumArray_typename[valueinfo->type])); 7 | return TCL_ERROR; 8 | #else 9 | 10 | if (ISSCALARINFO(valueinfo)) { 11 | /* special case of scalar value. This is assigned 12 | * to all elements in the slice. */ 13 | NumArrayIterator cpyit, srcit; 14 | NumArrayIteratorInitObj(NULL, value, &srcit); /* can't fail anymore */ 15 | TRES op = GETOP; 16 | 17 | NumArrayIteratorInit(sliceinfo, sharedbuf, &cpyit); 18 | TRES *result = NumArrayIteratorDeRefPtr(&cpyit); 19 | const index_t cpypitch=NumArrayIteratorRowPitchTyped(&cpyit); 20 | const index_t length = NumArrayIteratorRowLength(&cpyit); 21 | while (result) { 22 | index_t i; 23 | for (i=0; itype); 46 | 47 | if (ISSCALARINFO(info)) { 48 | continue; 49 | /* Scalars are always compatible */ 50 | } 51 | 52 | if (baseinfo == NULL) { 53 | /* save the first non-scalar info 54 | * and use it for subsequent comparisons */ 55 | baseinfo = info; 56 | continue; 57 | } 58 | 59 | if (!NumArrayCompatibleDimensions(baseinfo, info)) { 60 | Tcl_SetResult(interp, "Incompatible operands", NULL); 61 | return TCL_ERROR; 62 | } 63 | 64 | /* Save the most complex operand shape 65 | * for the result */ 66 | if (info->nDim > baseinfo->nDim) { 67 | baseinfo = info; 68 | } 69 | } 70 | 71 | /* For now, do only doubles */ 72 | if (resulttype != NumArray_Float64) { 73 | Tcl_SetResult(interp, "Only doubles are implemented", NULL); 74 | return TCL_ERROR; 75 | } 76 | 77 | if (bclength%4 != 0) { 78 | /* A bytecode is CMD OP1 OP2 OP3 79 | to perform, e.g., op1=op2+op3 */ 80 | Tcl_SetResult(interp, "Error in bytecode, length % 4 != 0", NULL); 81 | return TCL_ERROR; 82 | } 83 | 84 | /* create result */ 85 | NumArrayInfo *resultinfo=CreateNumArrayInfo(baseinfo->nDim, baseinfo->dims, resulttype); 86 | NumArraySharedBuffer *resultbuf=NumArrayNewSharedBuffer(resultinfo->bufsize); 87 | Tcl_Obj *result = Tcl_NewObj(); 88 | NumArraySetInternalRep(result, resultbuf, resultinfo); 89 | 90 | /* Run through the bytecode and find the highest register number */ 91 | int nregs=0; 92 | int b; 93 | for (b=0; bnregs) nregs=bc[b+1]; 96 | if (bc[b+2]>nregs) nregs=bc[b+2]; 97 | if (bc[b+3]>nregs) nregs=bc[b+3]; 98 | } 99 | nregs+=1; 100 | 101 | /* Maybe the number of operands exceeds the 102 | * addressed registers */ 103 | 104 | if (noperands+1>nregs) nregs=noperands+1; 105 | 106 | /* reserve memory for the registers */ 107 | /* For mixed types, this must be an array of NumArray_Value 108 | * with corresponding translated bytecode TODO */ 109 | #define REGTYPE double 110 | REGTYPE *registers = ckalloc(sizeof(REGTYPE)*nregs); 111 | 112 | /* create iterators and pitches */ 113 | NumArrayIterator *opit = ckalloc(sizeof(NumArrayIterator)*noperands); 114 | int *rpitches = ckalloc(sizeof(int)*noperands); 115 | char **rowptrs = ckalloc(sizeof(char *)*noperands); 116 | for (i=0; ibufsize) / NumArrayType_SizeOf(resulttype); 124 | int rowlength = 1; 125 | for (i=0; iinternalRep.twoPtrValue.ptr2; 84 | info2 = naObj2->internalRep.twoPtrValue.ptr2; 85 | /* map to int,double,complex - workaround 86 | * until we have the real implementation */ 87 | int ind1=NumArrayCompatTypeMap[info1->type]; 88 | int ind2=NumArrayCompatTypeMap[info2->type]; 89 | if (ind1 < 0 || ind2 < 0) { 90 | *resultObj = Tcl_ObjPrintf("Operator undefined for types %s, %s", NumArray_typename[info1->type], NumArray_typename[info2->type]); 91 | return TCL_ERROR; 92 | } 93 | return LOOPTBL[ind1][ind2](naObj1, naObj2, resultObj); 94 | } 95 | 96 | /* Implement the inner loop for the binary operators 97 | * for all datatypes */ 98 | 99 | /* (NaWideInt,NaWideInt) -> NaWideInt */ 100 | #ifdef INTRES 101 | #define TRES INTRES 102 | #else 103 | #define TRES NaWideInt 104 | #endif 105 | #define T1 NaWideInt 106 | #define T2 NaWideInt 107 | 108 | #ifdef OPINT 109 | #define OP OPINT 110 | #endif 111 | 112 | #include "binop_loop.h" 113 | 114 | 115 | /* (NaWideInt,double) -> double */ 116 | #ifdef DBLRES 117 | #define TRES DBLRES 118 | #else 119 | #define TRES double 120 | #endif 121 | #define T1 NaWideInt 122 | #define T2 double 123 | #ifdef OPDBL 124 | #define OP OPDBL 125 | #endif 126 | #include "binop_loop.h" 127 | 128 | /* (double, NaWideInt) -> double */ 129 | #ifdef DBLRES 130 | #define TRES DBLRES 131 | #else 132 | #define TRES double 133 | #endif 134 | #define T1 double 135 | #define T2 NaWideInt 136 | #ifdef OPDBL 137 | #define OP OPDBL 138 | #endif 139 | #include "binop_loop.h" 140 | 141 | /* (double, double) -> double */ 142 | #ifdef DBLRES 143 | #define TRES DBLRES 144 | #else 145 | #define TRES double 146 | #endif 147 | #define T1 double 148 | #define T2 double 149 | #ifdef OPDBL 150 | #define OP OPDBL 151 | #endif 152 | #include "binop_loop.h" 153 | 154 | /* (NaWideInt, complex) -> complex */ 155 | #ifdef CPLXRES 156 | #define TRES CPLXRES 157 | #else 158 | #define TRES NumArray_Complex 159 | #endif 160 | #define T1 NaWideInt 161 | #define T2 NumArray_Complex 162 | #ifdef OPCPLX 163 | #define OP OPCPLX 164 | #endif 165 | #include "binop_loop.h" 166 | 167 | /* (double, complex) -> complex */ 168 | #ifdef CPLXRES 169 | #define TRES CPLXRES 170 | #else 171 | #define TRES NumArray_Complex 172 | #endif 173 | #define T1 double 174 | #define T2 NumArray_Complex 175 | #ifdef OPCPLX 176 | #define OP OPCPLX 177 | #endif 178 | #include "binop_loop.h" 179 | 180 | /* (NaWideInt, complex) -> complex */ 181 | #ifdef CPLXRES 182 | #define TRES CPLXRES 183 | #else 184 | #define TRES NumArray_Complex 185 | #endif 186 | #define T1 NumArray_Complex 187 | #define T2 NaWideInt 188 | #ifdef OPCPLX 189 | #define OP OPCPLX 190 | #endif 191 | #include "binop_loop.h" 192 | 193 | /* (double, complex) -> complex */ 194 | #ifdef CPLXRES 195 | #define TRES CPLXRES 196 | #else 197 | #define TRES NumArray_Complex 198 | #endif 199 | #define T1 NumArray_Complex 200 | #define T2 double 201 | #ifdef OPCPLX 202 | #define OP OPCPLX 203 | #endif 204 | #include "binop_loop.h" 205 | 206 | /* (complex, complex) -> complex */ 207 | #ifdef CPLXRES 208 | #define TRES CPLXRES 209 | #else 210 | #define TRES NumArray_Complex 211 | #endif 212 | #define T1 NumArray_Complex 213 | #define T2 NumArray_Complex 214 | #ifdef OPCPLX 215 | #define OP OPCPLX 216 | #endif 217 | #include "binop_loop.h" 218 | 219 | 220 | #undef GETOP1 221 | #undef GETOP2 222 | #undef GETOP_IMP 223 | 224 | #undef CMD 225 | #undef TCLCMD 226 | #undef OP 227 | #undef OPINT 228 | #undef OPDBL 229 | #undef OPCPLX 230 | #undef INTRES 231 | #undef DBLRES 232 | #undef CPLXRES 233 | -------------------------------------------------------------------------------- /generic/binop_loop.h: -------------------------------------------------------------------------------- 1 | #define TUP UPCAST_COMMON(T1, T2) 2 | /* for scalar values, take the first value as 3 | * the constant and operate over the second field */ 4 | static int BINOP_LOOP_FUN(CMD, T1, T2) (Tcl_Obj *naObj1, Tcl_Obj *naObj2, Tcl_Obj **resultObj) { 5 | NumArrayInfo *info1 = naObj1->internalRep.twoPtrValue.ptr2; 6 | NumArrayInfo *info2 = naObj2->internalRep.twoPtrValue.ptr2; 7 | 8 | #ifndef OP 9 | *resultObj = Tcl_ObjPrintf("Operator undefined for types %s, %s", NumArray_typename[info1->type], NumArray_typename[info2->type]); 10 | return TCL_ERROR; 11 | #else 12 | 13 | /* check if the operands have compatible dimensions */ 14 | if (!NumArrayCompatibleDimensions(info1, info2) && 15 | !ISSCALARINFO(info1) && !ISSCALARINFO(info2)) { 16 | 17 | *resultObj = Tcl_NewStringObj("incompatible operands", -1); 18 | return TCL_ERROR; 19 | } 20 | 21 | /* Create new object */ 22 | NumArrayType resulttype = NATYPE_FROM_C(TRES); 23 | NumArrayInfo *resultinfo; 24 | /* Keep more complex dimension */ 25 | if (ISSCALARINFO(info1)) { 26 | resultinfo = CreateNumArrayInfo(info2 -> nDim, info2 -> dims, resulttype); 27 | } else if (ISSCALARINFO(info2)) { 28 | resultinfo = CreateNumArrayInfo(info1 -> nDim, info1 -> dims, resulttype); 29 | } else if (info1->nDim > info2 -> nDim) { 30 | resultinfo = CreateNumArrayInfo(info1 -> nDim, info1 -> dims, resulttype); 31 | } else { 32 | resultinfo = CreateNumArrayInfo(info2 -> nDim, info2 -> dims, resulttype); 33 | } 34 | 35 | /* allocate buffer of this size */ 36 | NumArraySharedBuffer *sharedbuf = NumArrayNewSharedBuffer(resultinfo -> bufsize); 37 | char *bufptr = NumArrayGetPtrFromSharedBuffer(sharedbuf); 38 | 39 | /* the new shared buffer is in canonical form, 40 | * thus we can simply iterate over it by pointer 41 | * arithmetics. But the input arrays may be non-canonical 42 | * TODO optimize for canonical case */ 43 | 44 | NumArrayIterator it1, it2; 45 | NumArrayIteratorInitObj(NULL, naObj1, &it1); 46 | NumArrayIteratorInitObj(NULL, naObj2, &it2); 47 | 48 | const index_t pitch = sizeof(TRES); 49 | if (ISSCALARINFO(info1)) { 50 | T1 *op1ptr = NumArrayIteratorDeRefPtr(&it1); 51 | TUP op1 = UPCAST(T1, TUP, *op1ptr); 52 | T2 *op2ptr = NumArrayIteratorDeRefPtr(&it2); 53 | const index_t op2pitch = NumArrayIteratorRowPitchTyped(&it2); 54 | const index_t length = NumArrayIteratorRowLength(&it2); 55 | while (op2ptr) { 56 | index_t i; 57 | for (i=0; i 3 | MODULE_SCOPE /* Subroutine */ int dgesdd_ (Tcl_Interp *interp, char *jobz, integer *m, integer *n, doublereal * a, integer *lda, doublereal *s, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, integer *iwork, integer *info); 4 | MODULE_SCOPE /* Subroutine */ int zgesdd_ (Tcl_Interp *interp, char *jobz, integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u, integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work, integer *lwork, doublereal *rwork, integer *iwork, integer *info); 5 | MODULE_SCOPE /* Subroutine */ int dgemm_ (Tcl_Interp *interp, char *transa, char *transb, integer *m, integer * n, integer *k, doublereal *alpha, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, integer *ldc); 6 | MODULE_SCOPE /* Subroutine */ int zgemm_ (Tcl_Interp *interp, char *transa, char *transb, integer *m, integer * n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex * c__, integer *ldc); 7 | MODULE_SCOPE /* Subroutine */ int dsyevr_ (Tcl_Interp *interp, char *jobz, char *range, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer * il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info); 8 | MODULE_SCOPE /* Subroutine */ int zheevr_ (Tcl_Interp *interp, char *jobz, char *range, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal * w, doublecomplex *z__, integer *ldz, integer *isuppz, doublecomplex * work, integer *lwork, doublereal *rwork, integer *lrwork, integer * iwork, integer *liwork, integer *info); 9 | MODULE_SCOPE /* Subroutine */ int dgeev_ (Tcl_Interp *interp, char *jobvl, char *jobvr, integer *n, doublereal * a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, integer *info); 10 | MODULE_SCOPE /* Subroutine */ int zgeev_ (Tcl_Interp *interp, char *jobvl, char *jobvr, integer *n, doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info); 11 | MODULE_SCOPE /* Subroutine */ int dgelss_ (Tcl_Interp *interp, integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, integer *info); 12 | MODULE_SCOPE /* Subroutine */ int zgelss_ (Tcl_Interp *interp, integer *m, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info); 13 | MODULE_SCOPE /* Subroutine */ int dgelsy_ (Tcl_Interp *interp, integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * jpvt, doublereal *rcond, integer *rank, doublereal *work, integer * lwork, integer *info); 14 | MODULE_SCOPE /* Subroutine */ int zgelsy_ (Tcl_Interp *interp, integer *m, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info); 15 | MODULE_SCOPE /* Subroutine */ int dgesv_ (Tcl_Interp *interp, integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info); 16 | MODULE_SCOPE /* Subroutine */ int zgesv_ (Tcl_Interp *interp, integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer * info); 17 | MODULE_SCOPE /* Subroutine */ int dgesvx_ (Tcl_Interp *interp, char *fact, char *trans, integer *n, integer * nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, char *equed, doublereal *r__, doublereal *c__, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal * rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer * iwork, integer *info); 18 | MODULE_SCOPE /* Subroutine */ int zgesvx_ (Tcl_Interp *interp, char *fact, char *trans, integer *n, integer * nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer * ldaf, integer *ipiv, char *equed, doublereal *r__, doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex * work, doublereal *rwork, integer *info); 19 | MODULE_SCOPE /* Subroutine */ int dgees_ (Tcl_Interp *interp, char *jobvs, char *sort, L_fp select, integer *n, doublereal *a, integer *lda, integer *sdim, doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work, integer *lwork, logical *bwork, integer *info); 20 | MODULE_SCOPE /* Subroutine */ int zgees_ (Tcl_Interp *interp, char *jobvs, char *sort, L_fp select, integer *n, doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w, doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork, doublereal *rwork, logical *bwork, integer *info); 21 | 22 | -------------------------------------------------------------------------------- /generic/compathack.c: -------------------------------------------------------------------------------- 1 | #include "compathack.h" 2 | 3 | const NumArrayType NumArrayCompatTypeMap[NumArray_SentinelType] = { 4 | -1,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,1,-1,2,-1 5 | }; 6 | -------------------------------------------------------------------------------- /generic/compathack.h: -------------------------------------------------------------------------------- 1 | #ifndef COMPATHACK_H 2 | #define COMPATHACK_H 3 | #include "vectcl.h" 4 | extern const NumArrayType NumArrayCompatTypeMap[NumArray_SentinelType]; 5 | #endif 6 | -------------------------------------------------------------------------------- /generic/compathack.tcl.c: -------------------------------------------------------------------------------- 1 | #include "compathack.h" 2 | 3 | const NumArrayType NumArrayCompatTypeMap[NumArray_SentinelType] = { 4 | ${ 5 | set map {NumArray_Int NumArray_Float64 NumArray_Complex128} 6 | set indlist [lmap type $NA_ALLTYPES {lsearch $map $type}] 7 | join $indlist , 8 | $} 9 | }; 10 | -------------------------------------------------------------------------------- /generic/defs.tcl: -------------------------------------------------------------------------------- 1 | # note: the order in this list matters 2 | # it defines upconversion between different types 3 | # pure integer upconverts to all fixed-types, because we want e.g. 3i8 + 2 = 5i8 4 | # fixed-width integers upconvert analogously to C 5 | # enum ctype vectcltype 6 | set typetable { 7 | NumArray_Bool int bool 8 | NumArray_Int NaWideInt int 9 | NumArray_Int8 int8_t int8 10 | NumArray_Uint8 uint8_t uint8 11 | NumArray_Int16 int16_t int16 12 | NumArray_Uint16 uint16_t uint16 13 | NumArray_Int32 int32_t int32 14 | NumArray_Uint32 uint32_t uint32 15 | NumArray_Int64 int64_t int64 16 | NumArray_Uint64 uint64_t uint64 17 | NumArray_Float32 float float 18 | NumArray_Float64 double double 19 | NumArray_Complex64 NumArray_ComplexFloat complex64 20 | NumArray_Complex128 NumArray_Complex complex128 21 | NumArray_Tcl_Obj Tcl_Obj* value 22 | } 23 | 24 | 25 | set NA_FIXEDINTEGERS { 26 | NumArray_Int8 27 | NumArray_Uint8 28 | NumArray_Int16 29 | NumArray_Uint16 30 | NumArray_Int32 31 | NumArray_Uint32 32 | NumArray_Int64 33 | NumArray_Uint64 34 | } 35 | 36 | set NA_SIGNEDINTEGERS { 37 | NumArray_Int 38 | NumArray_Int8 39 | NumArray_Int16 40 | NumArray_Int32 41 | NumArray_Int64 42 | } 43 | 44 | set NA_UNSIGNEDINTEGERS { 45 | NumArray_Uint8 46 | NumArray_Uint16 47 | NumArray_Uint32 48 | NumArray_Uint64 49 | } 50 | 51 | set NA_TYPESUFFIXES { 52 | NumArray_Int "" 53 | NumArray_Int8 i8 54 | NumArray_Int16 i16 55 | NumArray_Int32 i32 56 | NumArray_Int64 i64 57 | NumArray_Uint8 u8 58 | NumArray_Uint16 u16 59 | NumArray_Uint32 u32 60 | NumArray_Uint64 u64 61 | } 62 | 63 | set NA_INTEGERS [list NumArray_Int NumArray_Bool {*}$NA_FIXEDINTEGERS] 64 | set NA_REALFLOATS {NumArray_Float32 NumArray_Float64} 65 | 66 | set NA_REALTYPES [list {*}$NA_INTEGERS {*}$NA_REALFLOATS] 67 | set NA_COMPLEXTYPES {NumArray_Complex64 NumArray_Complex128} 68 | 69 | 70 | foreach {enum ctype vectcltype} $typetable { 71 | dict set NA_TO_CTYPE $enum $ctype 72 | dict set NA_TO_VECTCLTYPE $enum $vectcltype 73 | } 74 | 75 | set NA_ALLTYPES [dict keys $NA_TO_CTYPE] 76 | set NA_NUMERICTYPES [lrange $NA_ALLTYPES 0 end-1] ;# remove the Tcl_Obj type 77 | 78 | # converting types in binary operators 79 | # given type1 and type2, this computes the result type 80 | proc upcast_common_type {type1 type2} { 81 | variable NA_NUMERICTYPES 82 | set ind1 [lindex $type1 $NA_NUMERICTYPES] 83 | set ind2 [lindex $type2 $NA_NUMERICTYPES] 84 | if { $ind1<0 || $ind2 < 0} { 85 | return -code error "Unknown data types $type1, $type2" 86 | } 87 | return [lindex $NA_NUMERICTYPES [expr {max($ind1, $ind2)}] 88 | } 89 | 90 | proc upcast_type {from to} { 91 | C { 92 | /* all conversions which can be done by the C compiler */ 93 | #define BUILTINCONV(X, Y) \ 94 | if (type == X && info -> type == Y) { \ 95 | C_FROM_NATYPE(X) *bufptr = NumArrayIteratorDeRefPtr(&convit); \ 96 | for (; ! NumArrayIteratorFinished(&it); NumArrayIteratorAdvance(&it)) { \ 97 | * bufptr++ = (C_FROM_NATYPE(X)) (*((C_FROM_NATYPE(Y)*)NumArrayIteratorDeRefPtr(&it))); \ 98 | } \ 99 | goto ready; \ 100 | } 101 | 102 | } 103 | } 104 | proc cquote {x} { 105 | set q [string map {\" \"\" \\ \\\\} $x] 106 | return "\"$q\"" 107 | } 108 | 109 | proc = {v} { upvar $v n; return $n } 110 | -------------------------------------------------------------------------------- /generic/dotproductloop.h: -------------------------------------------------------------------------------- 1 | /* dot product for input types T1, T2 and output TRES */ 2 | /* helper macros to deal with different types */ 3 | 4 | #define INIT_NaWideInt NaWideInt sum=0; 5 | #define INIT_double double sum=0; 6 | #define INIT_NumArray_Complex NumArray_Complex sum=NumArray_mkComplex(0.0, 0.0); 7 | 8 | #define PRODUCT_NaWideInt(X, Y) X*Y 9 | #define PRODUCT_double(X, Y) X*Y 10 | #define PRODUCT_NumArray_Complex(X, Y) NumArray_ComplexMultiply(X, Y) 11 | #define ADDTO_NaWideInt(var, expr) var += expr 12 | #define ADDTO_double(var, expr) var += expr 13 | #define ADDTO_NumArray_Complex(var, expr) var = NumArray_ComplexAdd(var, expr) 14 | 15 | #define INIT INIT_help(TRES) 16 | #define INIT_help(TRES) NUMARRAYTPASTER(INIT_, TRES) 17 | #define PRODUCT(X, Y) PRODUCT_help(TRES, X, Y) 18 | #define PRODUCT_help(TRES, X, Y) NUMARRAYTPASTER(PRODUCT_, TRES)(X, Y) 19 | #define ADDTO(X, Y) ADDTO_help(TRES, X, Y) 20 | #define ADDTO_help(TRES, X, Y) NUMARRAYTPASTER(ADDTO_, TRES)(X, Y) 21 | 22 | /* switch on datatypes */ 23 | 24 | if (info1->type == NATYPE_FROM_C(T1) && info2->type == NATYPE_FROM_C(T2)) { 25 | /* check if the operands have compatible dimensions */ 26 | /* could be Kronecker product of two vectors */ 27 | if (info1->nDim == 1 && info2->nDim ==2 && info2->dims[0] == 1) { 28 | index_t resultdims[2]; 29 | resultdims[0] = info1->dims[0]; 30 | resultdims[1] = info2->dims[1]; 31 | resultinfo = CreateNumArrayInfo(2, resultdims, info1->type); 32 | sharedbuf = NumArrayNewSharedBuffer(resultinfo->bufsize); 33 | 34 | TRES *bufptr = (TRES *)NumArrayGetPtrFromSharedBuffer(sharedbuf); 35 | 36 | NumArrayIterator it1; 37 | NumArrayIterator it2; 38 | NumArrayIteratorInitObj(NULL, naObj1, &it1); 39 | NumArrayIteratorInitObj(NULL, naObj2, &it2); 40 | 41 | /* outer loop */ 42 | while (!NumArrayIteratorFinished(&it1)) { 43 | TRES v1 = UPCAST(T1, TRES, *(T1 *) NumArrayIteratorDeRefPtr(&it1)); 44 | void *op2ptr = NumArrayIteratorReset(&it2); 45 | /* inner loop */ 46 | while (op2ptr) { 47 | TRES v2 = UPCAST(T2, TRES, *(T2 *) op2ptr); 48 | *bufptr++ = PRODUCT(v1, v2); 49 | op2ptr = NumArrayIteratorAdvance(&it2); 50 | } 51 | 52 | NumArrayIteratorAdvance(&it1); 53 | } 54 | 55 | NumArrayIteratorFree(&it1); 56 | NumArrayIteratorFree(&it2); 57 | } else if (info1->nDim>1 && info1->dims[info1->nDim-1] == info2->dims[0]) { 58 | /* standard matrix multiplikation */ 59 | 60 | info2 = DupNumArrayInfo(info2); 61 | const index_t op2pitch = info2->pitches[0]; 62 | 63 | int resultndim = info1->nDim + info2->nDim - 2; 64 | index_t *dims=ckalloc(sizeof(index_t)*resultndim); 65 | int d; 66 | 67 | for (d=0; dnDim-1; d++) { 68 | dims[d]=info1->dims[d]; 69 | } 70 | for (d=1; dnDim; d++) { 71 | dims[d+info1->nDim-2]=info2->dims[d]; 72 | } 73 | 74 | resultinfo = CreateNumArrayInfo(resultndim, dims, 75 | NumArray_UpcastCommonType(info1->type, info2->type)); 76 | ckfree(dims); 77 | 78 | sharedbuf = NumArrayNewSharedBuffer(resultinfo -> bufsize); 79 | 80 | 81 | NumArraySharedBuffer *buf1 = naObj1 -> internalRep.twoPtrValue.ptr1; 82 | NumArraySharedBuffer *buf2 = naObj2 -> internalRep.twoPtrValue.ptr1; 83 | 84 | NumArrayInfoSlice1Axis(NULL, info2, 0, 0, 0, 1); 85 | 86 | NumArrayIterator it1; 87 | NumArrayIterator it2; 88 | NumArrayIteratorInit(info1, buf1, &it1); 89 | NumArrayIteratorInit(info2, buf2, &it2); 90 | 91 | /* Now run nested loop, outer = op1, inner = op2 */ 92 | const index_t op1pitch = NumArrayIteratorRowPitch(&it1); 93 | TRES *result = (TRES *) NumArrayGetPtrFromSharedBuffer(sharedbuf); 94 | char *op1ptr = NumArrayIteratorDeRefPtr(&it1); 95 | 96 | const index_t length = NumArrayIteratorRowLength(&it1); 97 | 98 | while (op1ptr) { 99 | char *op2ptr = NumArrayIteratorReset(&it2); 100 | while (op2ptr) { 101 | INIT; 102 | index_t i; 103 | for (i=0; i internalRep.twoPtrValue.ptr1; 50 | info = naObj -> internalRep.twoPtrValue.ptr2; 51 | /* if input is not complex, copy to new buffer */ 52 | 53 | if (info -> type != NumArray_Complex128 || !info->canonical) { 54 | inpinfo = CreateNumArrayInfo(info -> nDim, info -> dims, NumArray_Complex128); 55 | inpsharedbuf = NumArrayNewSharedBuffer(inpinfo -> bufsize); 56 | if (NumArrayCopy(info, sharedbuf, inpinfo, inpsharedbuf)!= TCL_OK) { 57 | Tcl_SetResult(interp, "Can't convert input to complex", NULL); 58 | return TCL_ERROR; 59 | } 60 | allocbuf = 1; 61 | } else { 62 | inpsharedbuf = sharedbuf; 63 | inpinfo = info; 64 | allocbuf = 0; 65 | } 66 | 67 | /* Currently, only unit-stride vectors are supported */ 68 | if (inpinfo -> nDim !=1) { 69 | Tcl_SetResult(interp, "N-D-FFT not implemented", NULL); 70 | goto cleanbuf; 71 | } 72 | 73 | 74 | /* reserve memory for output 75 | * for vectors, it is the same as the input */ 76 | NumArrayInfo *resultinfo = DupNumArrayInfo(inpinfo); 77 | NumArraySharedBuffer *resultsharedbuf = NumArrayNewSharedBuffer(inpinfo->bufsize); 78 | 79 | NumArray_Complex *ibuf = NumArrayGetPtrFromSharedBuffer(inpsharedbuf); 80 | NumArray_Complex *obuf = NumArrayGetPtrFromSharedBuffer(resultsharedbuf); 81 | /* perform FFT */ 82 | if (inpinfo->dims[0] != 0) { 83 | /* Do nothing for an empty array */ 84 | fft_object workspace=fft_init(inpinfo->dims[0], sgn); 85 | fft_exec(workspace, ibuf, obuf); 86 | 87 | } 88 | 89 | /* free working copy of input */ 90 | if (allocbuf) { 91 | NumArraySharedBufferDecrRefcount(inpsharedbuf); 92 | DeleteNumArrayInfo(inpinfo); 93 | } 94 | 95 | /* put result into interpreter */ 96 | 97 | Tcl_Obj *result = Tcl_NewObj(); 98 | NumArraySetInternalRep(result, resultsharedbuf, resultinfo); 99 | Tcl_SetObjResult(interp, result); 100 | return TCL_OK; 101 | 102 | cleanbuf: 103 | if (allocbuf) { 104 | NumArraySharedBufferDecrRefcount(inpsharedbuf); 105 | DeleteNumArrayInfo(inpinfo); 106 | } 107 | return TCL_ERROR; 108 | } 109 | 110 | 111 | -------------------------------------------------------------------------------- /generic/fft.h: -------------------------------------------------------------------------------- 1 | #ifndef VECTCL_FFT_H 2 | #define VECTCL_FFT_H 3 | #include "vectclInt.h" 4 | SUBCOMMAND(NumArrayFFTCmd); 5 | SUBCOMMAND(NumArrayIFFTCmd); 6 | 7 | #endif 8 | -------------------------------------------------------------------------------- /generic/hsfft.h: -------------------------------------------------------------------------------- 1 | /* 2 | * hsfft.h 3 | * 4 | * Created on: Apr 14, 2013 5 | * Author: Rafat Hussain 6 | */ 7 | 8 | #ifndef HSFFT_H_ 9 | #define HSFFT_H_ 10 | 11 | #include 12 | #include 13 | #include 14 | 15 | #include "nacomplex.h" 16 | 17 | #ifdef __cplusplus 18 | extern "C" { 19 | #endif 20 | 21 | #define PI2 6.28318530717958647692528676655900577 22 | 23 | typedef struct fft_set* fft_object; 24 | 25 | fft_object fft_init(int N, int sgn); 26 | void fft_exec(fft_object obj,NumArray_Complex *inp,NumArray_Complex *oup); 27 | void free_fft(fft_object object); 28 | 29 | #ifdef __cplusplus 30 | } 31 | #endif 32 | 33 | 34 | 35 | 36 | #endif /* HSFFT_H_ */ 37 | -------------------------------------------------------------------------------- /generic/intconv.c: -------------------------------------------------------------------------------- 1 | #include "intconv.h" 2 | #include 3 | 4 | const char digit_pairs[201] = { 5 | "00010203040506070809" 6 | "10111213141516171819" 7 | "20212223242526272829" 8 | "30313233343536373839" 9 | "40414243444546474849" 10 | "50515253545556575859" 11 | "60616263646566676869" 12 | "70717273747576777879" 13 | "80818283848586878889" 14 | "90919293949596979899" 15 | }; 16 | 17 | #define MAXDIGITS 20 18 | 19 | const uint64_t powersoften[MAXDIGITS] = { 20 | 1u, 10u, 100, 1000, 10000, 100000, 21 | 1000000u, 10000000, 100000000, 22 | 1000000000u, 10000000000, 100000000000, 23 | 1000000000000u, 10000000000000, 24 | 100000000000000u, 1000000000000000, 25 | 10000000000000000u, 100000000000000000, 26 | 1000000000000000000u, 10000000000000000000u 27 | }; 28 | 29 | int format_uint64(uint64_t val, char *s) 30 | { 31 | if(val==0) 32 | { 33 | s[0]='0'; 34 | s[1]='\0'; 35 | return 1; 36 | } 37 | 38 | int size=1; 39 | while (val >= powersoften[size] && size < MAXDIGITS) { size++; } 40 | 41 | char* c = s+size-1; 42 | while(val>=100) 43 | { 44 | int pos = val % 100; 45 | val /= 100; 46 | *(short*)(c-1)=*(short*)(digit_pairs+2*pos); 47 | c-=2; 48 | } 49 | while(val>0) 50 | { 51 | *c--='0' + (val % 10); 52 | val /= 10; 53 | } 54 | s[size]='\0'; 55 | return size; 56 | } 57 | 58 | int format_int64(int64_t val, char *s) { 59 | if (val < 0) { 60 | s[0]='-'; 61 | return format_uint64(-val, s+1)+1; 62 | } else { 63 | return format_uint64(val, s); 64 | } 65 | } 66 | 67 | int format_bool(int val, char *s) { 68 | if (val == 0) { 69 | strcpy(s, "false"); 70 | return 5; 71 | } else { 72 | strcpy(s, "true"); 73 | return 4; 74 | } 75 | } 76 | 77 | /* 78 | int main () { 79 | 80 | char out[NA_INTSPACE]; char out2[NA_INTSPACE]; 81 | for (int i=-30; i<30; i++) { 82 | format_int64(i*100, out); 83 | format_uint64(i, out2); 84 | printf("%d %s %s\n", i, out, out2); 85 | } 86 | return 0; 87 | } */ 88 | -------------------------------------------------------------------------------- /generic/intconv.h: -------------------------------------------------------------------------------- 1 | #include 2 | #define NA_INTSPACE 21 3 | int format_uint64(uint64_t val, char *s); 4 | int format_int64(int64_t val, char *s); 5 | int format_bool(int val, char *s); 6 | -------------------------------------------------------------------------------- /generic/linalg.h: -------------------------------------------------------------------------------- 1 | /* function definitions for basic linear algebra 2 | * matrix decompositions / equation system solving */ 3 | 4 | #ifndef LINALG_H 5 | #define LINALG_H 6 | #include "vectclInt.h" 7 | 8 | int NumArrayDotCmd(ClientData dummy, Tcl_Interp *interp, 9 | int objc, Tcl_Obj *const *objv); 10 | 11 | int QRDecomposition(Tcl_Interp *interp, Tcl_Obj *matrix, Tcl_Obj **qr, Tcl_Obj **rdiag); 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /generic/map.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2012 William Swanson 3 | * 4 | * Permission is hereby granted, free of charge, to any person 5 | * obtaining a copy of this software and associated documentation 6 | * files (the "Software"), to deal in the Software without 7 | * restriction, including without limitation the rights to use, copy, 8 | * modify, merge, publish, distribute, sublicense, and/or sell copies 9 | * of the Software, and to permit persons to whom the Software is 10 | * furnished to do so, subject to the following conditions: 11 | * 12 | * The above copyright notice and this permission notice shall be 13 | * included in all copies or substantial portions of the Software. 14 | * 15 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 17 | * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY 19 | * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 20 | * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 21 | * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 22 | * 23 | * Except as contained in this notice, the names of the authors or 24 | * their institutions shall not be used in advertising or otherwise to 25 | * promote the sale, use or other dealings in this Software without 26 | * prior written authorization from the authors. 27 | */ 28 | 29 | #ifndef MAP_H_INCLUDED 30 | #define MAP_H_INCLUDED 31 | 32 | #define EVAL0(...) __VA_ARGS__ 33 | #define EVAL1(...) EVAL0 (EVAL0 (EVAL0 (__VA_ARGS__))) 34 | #define EVAL2(...) EVAL1 (EVAL1 (EVAL1 (__VA_ARGS__))) 35 | #define EVAL3(...) EVAL2 (EVAL2 (EVAL2 (__VA_ARGS__))) 36 | #define EVAL4(...) EVAL3 (EVAL3 (EVAL3 (__VA_ARGS__))) 37 | #define EVAL(...) EVAL4 (EVAL4 (EVAL4 (__VA_ARGS__))) 38 | 39 | #define MAP_END(...) 40 | #define MAP_OUT 41 | 42 | #define MAP_GET_END() 0, MAP_END 43 | #define MAP_NEXT0(test, next, ...) next MAP_OUT 44 | #define MAP_NEXT1(test, next) MAP_NEXT0 (test, next, 0) 45 | #define MAP_NEXT(test, next) MAP_NEXT1 (MAP_GET_END test, next) 46 | 47 | #define MAP0(f, x, peek, ...) f(x) MAP_NEXT (peek, MAP1) (f, peek, __VA_ARGS__) 48 | #define MAP1(f, x, peek, ...) f(x) MAP_NEXT (peek, MAP0) (f, peek, __VA_ARGS__) 49 | #define MAP(f, ...) EVAL (MAP1 (f, __VA_ARGS__, (), 0)) 50 | 51 | /* Variant with one extra argument passed into f 52 | * Can be used to construct nested loops */ 53 | #define ARGEVAL0(...) __VA_ARGS__ 54 | #define ARGEVAL1(...) ARGEVAL0 (ARGEVAL0 (ARGEVAL0 (__VA_ARGS__))) 55 | #define ARGEVAL2(...) ARGEVAL1 (ARGEVAL1 (ARGEVAL1 (__VA_ARGS__))) 56 | #define ARGEVAL3(...) ARGEVAL2 (ARGEVAL2 (ARGEVAL2 (__VA_ARGS__))) 57 | #define ARGEVAL4(...) ARGEVAL3 (ARGEVAL3 (ARGEVAL3 (__VA_ARGS__))) 58 | #define ARGEVAL(...) ARGEVAL4 (ARGEVAL4 (ARGEVAL4 (__VA_ARGS__))) 59 | 60 | 61 | #define MAPARG0(f, arg, x, peek, ...) f(arg, x) MAP_NEXT (peek, MAPARG1) (f, arg, peek, __VA_ARGS__) 62 | #define MAPARG1(f, arg, x, peek, ...) f(arg, x) MAP_NEXT (peek, MAPARG0) (f, arg, peek, __VA_ARGS__) 63 | #define MAPARG(f, arg, ...) ARGEVAL(MAPARG1 (f, arg, __VA_ARGS__, (), 0)) 64 | 65 | 66 | #endif 67 | -------------------------------------------------------------------------------- /generic/nacomplex.h: -------------------------------------------------------------------------------- 1 | #ifndef NACOMPLEX_H 2 | #define NACOMPLEX_H 3 | #include 4 | #include 5 | 6 | typedef struct { 7 | float re; 8 | float im; 9 | } NumArray_ComplexFloat; 10 | 11 | typedef struct { 12 | double re; 13 | double im; 14 | } NumArray_Complex; 15 | 16 | 17 | Tcl_Obj * NumArray_NewComplexObj(NumArray_Complex c); 18 | 19 | int NumArray_GetComplexFromObj(Tcl_Interp *interp, Tcl_Obj *cplxobj, NumArray_Complex *result); 20 | 21 | /* Conversion into string buffer */ 22 | #define NUMARRAY_COMPLEX_SPACE (2*TCL_DOUBLE_SPACE+2) 23 | 24 | void NumArray_PrintComplex(NumArray_Complex c, char *buf); 25 | int NumArray_ParseComplex(Tcl_Interp *interp, const char *buf, NumArray_Complex *dest); 26 | 27 | /* Function to setup the complex value type */ 28 | int Complex_Init(Tcl_Interp *interp); 29 | 30 | /* Simple constructor. Hopefully optimized out */ 31 | static inline NumArray_Complex NumArray_mkComplex(double re, double im) { 32 | NumArray_Complex result; 33 | result.re = re; 34 | result.im = im; 35 | return result; 36 | } 37 | 38 | static inline NumArray_ComplexFloat NumArray_mkComplexFloat(float re, float im) { 39 | NumArray_ComplexFloat result; 40 | result.re = re; 41 | result.im = im; 42 | return result; 43 | } 44 | 45 | /* arithmetic operations */ 46 | static inline NumArray_Complex NumArray_ComplexNeg(NumArray_Complex c) { 47 | NumArray_Complex result; 48 | result.re = -c.re; 49 | result.im = -c.im; 50 | return result; 51 | } 52 | 53 | static inline NumArray_Complex NumArray_ComplexConj(NumArray_Complex c) { 54 | NumArray_Complex result; 55 | result.re = c.re; 56 | result.im = -c.im; 57 | return result; 58 | } 59 | 60 | static inline NumArray_Complex NumArray_ComplexAdd(NumArray_Complex c1, NumArray_Complex c2) { 61 | NumArray_Complex result; 62 | result.re = c1.re + c2.re; 63 | result.im = c1.im + c2.im; 64 | return result; 65 | } 66 | 67 | static inline NumArray_Complex NumArray_ComplexSubtract(NumArray_Complex c1, NumArray_Complex c2) { 68 | NumArray_Complex result; 69 | result.re = c1.re - c2.re; 70 | result.im = c1.im - c2.im; 71 | return result; 72 | } 73 | 74 | static inline NumArray_Complex NumArray_ComplexMultiply(NumArray_Complex c1, NumArray_Complex c2) { 75 | NumArray_Complex result; 76 | result.re = c1.re*c2.re - c1.im*c2.im; 77 | result.im = c1.re*c2.im + c1.im*c2.re; 78 | return result; 79 | } 80 | 81 | static inline NumArray_Complex NumArray_ComplexDivide(NumArray_Complex c1, NumArray_Complex c2) { 82 | NumArray_Complex result; 83 | double denom=c2.re*c2.re + c2.im*c2.im; 84 | result.re= (c1.re*c2.re + c1.im*c2.im)/denom; 85 | result.im= (c1.im*c2.re - c1.re*c2.im)/denom; 86 | return result; 87 | } 88 | 89 | /* Multiply by real number */ 90 | static inline NumArray_Complex NumArray_ComplexScale(NumArray_Complex c, double s) { 91 | NumArray_Complex result; 92 | result.re= c.re*s; 93 | result.im= c.im*s; 94 | return result; 95 | } 96 | 97 | static inline double NumArray_ComplexAbs(NumArray_Complex c) { 98 | return hypot(c.re, c.im); 99 | } 100 | 101 | static inline double NumArray_ComplexArg(NumArray_Complex c) { 102 | return atan2(c.im, c.re); 103 | } 104 | 105 | static inline NumArray_Complex NumArray_ComplexSign(NumArray_Complex c) { 106 | NumArray_Complex result; 107 | double v=hypot(c.re, c.im); 108 | if (v==0.0) { return NumArray_mkComplex(0.0, 0.0); } 109 | result.re=c.re/v; 110 | result.im=c.im/v; 111 | return result; 112 | } 113 | 114 | static inline NumArray_Complex NumArray_ComplexSqrt(NumArray_Complex c) { 115 | NumArray_Complex result; 116 | double absval=hypot(c.re, c.im); 117 | result.re= sqrt((absval + c.re)/2.0); 118 | result.im= c.im < 0 ? -sqrt((absval - c.re)/2.0) : sqrt((absval - c.re)/2.0); 119 | return result; 120 | } 121 | 122 | 123 | NumArray_Complex NumArray_ComplexPow(NumArray_Complex c1, NumArray_Complex c2); 124 | NumArray_Complex NumArray_ComplexSin(NumArray_Complex c); 125 | NumArray_Complex NumArray_ComplexCos(NumArray_Complex c); 126 | NumArray_Complex NumArray_ComplexTan(NumArray_Complex c); 127 | NumArray_Complex NumArray_ComplexExp(NumArray_Complex c); 128 | NumArray_Complex NumArray_ComplexLog(NumArray_Complex c); 129 | NumArray_Complex NumArray_ComplexSinh(NumArray_Complex c); 130 | NumArray_Complex NumArray_ComplexCosh(NumArray_Complex c); 131 | NumArray_Complex NumArray_ComplexTanh(NumArray_Complex c); 132 | NumArray_Complex NumArray_ComplexAsin(NumArray_Complex c); 133 | NumArray_Complex NumArray_ComplexAcos(NumArray_Complex c); 134 | NumArray_Complex NumArray_ComplexAtan(NumArray_Complex c); 135 | NumArray_Complex NumArray_ComplexAsinh(NumArray_Complex c); 136 | NumArray_Complex NumArray_ComplexAcosh(NumArray_Complex c); 137 | NumArray_Complex NumArray_ComplexAtanh(NumArray_Complex c); 138 | 139 | 140 | /* .... */ 141 | 142 | #endif 143 | -------------------------------------------------------------------------------- /generic/schur.c: -------------------------------------------------------------------------------- 1 | #include "schur.h" 2 | #include "clapack_cutdown.h" 3 | 4 | #define MIN(X, Y) ((X)<(Y) ? X : Y) 5 | #define MAX(X, Y) ((X)>(Y) ? X : Y) 6 | 7 | static int doSchur(Tcl_Interp *interp, Tcl_Obj *matrix, Tcl_Obj **Z, Tcl_Obj **T) { 8 | /* Compute Schur decomposition of a matrix. 9 | * Return Schur vectors in Z and Schur form in T, 10 | */ 11 | 12 | /* Convert matrix to VecTcl object */ 13 | NumArrayInfo *info = NumArrayGetInfoFromObj(interp, matrix); 14 | if (!info) { return TCL_ERROR; } 15 | 16 | /* Check that it is a square matrix */ 17 | if (info->nDim != 2) { 18 | /* Could be a scalar. In this case return the trivial 19 | * decomposition */ 20 | if (ISSCALARINFO(info)) { 21 | *T = Tcl_DuplicateObj(matrix); 22 | *Z = Tcl_NewDoubleObj(1.0); 23 | return TCL_OK; 24 | } 25 | 26 | Tcl_SetResult(interp, "Schur decomposition is only defined for square matrix", NULL); 27 | return TCL_ERROR; 28 | } 29 | 30 | 31 | /* get matrix dimensions */ 32 | long int m = info->dims[0]; 33 | long int n = info->dims[1]; 34 | 35 | if (m != n) { 36 | Tcl_SetResult(interp, "Schur decomposition is only defined for square matrix", NULL); 37 | return TCL_ERROR; 38 | } 39 | 40 | char *jobvs = "V"; 41 | char *sort = "N"; 42 | 43 | if (info->type != NumArray_Complex128) { 44 | /* Real-valued matrix, prepare for dgees */ 45 | /* create a column-major copy of matrix 46 | * This also converts an integer matrix to double */ 47 | *T = NumArrayNewMatrixColMaj(NumArray_Float64, m, n); 48 | NumArrayObjCopy(interp, matrix, *T); 49 | 50 | *Z = NumArrayNewMatrixColMaj(NumArray_Float64, m, m); 51 | 52 | /* Extract the raw pointers from the VecTcl objects */ 53 | double *Tptr = NumArrayGetPtrFromObj(interp, *T); 54 | double *Zptr = NumArrayGetPtrFromObj(interp, *Z); 55 | 56 | /* Space to store the eigenvalues */ 57 | doublereal *wr = ckalloc(sizeof(doublereal)*n); 58 | doublereal *wi = ckalloc(sizeof(doublereal)*n); 59 | 60 | /* setup workspace arrays */ 61 | integer lwork = 3*n; 62 | doublereal* work=ckalloc(sizeof(doublereal)*lwork); 63 | logical *bwork = NULL; 64 | integer sdim=0; 65 | 66 | /* Leading dimensions of T and Vr 67 | * Don't compute left vectors. */ 68 | integer ldt = n; 69 | integer ldz = n; 70 | integer info; 71 | 72 | /* Subroutine int dgees_(char *jobvs, char *sort, L_fp select, 73 | * integer *n, doublereal *a, integer *lda, integer *sdim, 74 | * doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs, 75 | * doublereal *work, integer *lwork, logical *bwork, integer *info) */ 76 | 77 | 78 | /* call out to dgees */ 79 | int errcode=dgees_(interp, jobvs, sort, NULL, 80 | &n, Tptr, &ldt, &sdim, 81 | wr, wi, Zptr, &ldz, 82 | work, &lwork, bwork, &info); 83 | 84 | /* free workspace */ 85 | ckfree(work); 86 | ckfree(wr); ckfree(wi); 87 | 88 | if (errcode != TCL_OK) { 89 | /* release temporary storage for result */ 90 | Tcl_DecrRefCount(*Z); 91 | Tcl_DecrRefCount(*T); 92 | if (errcode > 0) { 93 | RESULTPRINTF(("DGEES failed to converge at eigenvector %d ", info)); 94 | } 95 | return TCL_ERROR; 96 | } 97 | 98 | return TCL_OK; 99 | 100 | } else { 101 | /* Complex matrix, prepare for zgees */ 102 | /* create a column-major copy of matrix 103 | * This also converts an integer matrix to double */ 104 | *T = NumArrayNewMatrixColMaj(NumArray_Complex128, m, n); 105 | NumArrayObjCopy(interp, matrix, *T); 106 | 107 | *Z = NumArrayNewMatrixColMaj(NumArray_Complex128, m, m); 108 | 109 | /* Extract the raw pointers from the VecTcl objects */ 110 | doublecomplex *Tptr = NumArrayGetPtrFromObj(interp, *T); 111 | doublecomplex *Zptr = NumArrayGetPtrFromObj(interp, *Z); 112 | 113 | /* Space to store the eigenvalues */ 114 | doublecomplex *w = ckalloc(sizeof(doublecomplex)*n); 115 | 116 | /* setup workspace arrays */ 117 | integer lwork = 2*n; 118 | doublecomplex *work=ckalloc(sizeof(doublecomplex)*lwork); 119 | doublereal *rwork=ckalloc(sizeof(doublereal)*n); 120 | logical *bwork = NULL; 121 | integer sdim=0; 122 | 123 | /* Leading dimensions of T and Vr 124 | * Don't compute left vectors. */ 125 | integer ldt = n; 126 | integer ldz = n; 127 | integer info; 128 | 129 | /* Subroutine int zgees_(char *jobvs, char *sort, L_fp select, 130 | * integer *n, doublecomplex *a, integer *lda, integer *sdim, 131 | * doublecomplex *w, doublecomplex *vs, integer *ldvs, 132 | * doublecomplex *work, integer *lwork, doublereal *rwork, logical *bwork, integer *info) */ 133 | 134 | /* call out to dgees */ 135 | int errcode=zgees_(interp, jobvs, sort, NULL, 136 | &n, Tptr, &ldt, &sdim, 137 | w, Zptr, &ldz, 138 | work, &lwork, rwork, bwork, &info); 139 | 140 | /* free workspace */ 141 | ckfree(work); 142 | ckfree(rwork); 143 | ckfree(w); 144 | 145 | if (errcode != TCL_OK) { 146 | /* release temporary storage for result */ 147 | Tcl_DecrRefCount(*Z); 148 | Tcl_DecrRefCount(*T); 149 | if (errcode > 0) { 150 | RESULTPRINTF(("ZGEES failed to converge at eigenvector %d ", info)); 151 | } 152 | return TCL_ERROR; 153 | } 154 | 155 | return TCL_OK; 156 | 157 | } 158 | } 159 | 160 | int NumArraySchurCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { 161 | if (objc != 2) { 162 | Tcl_WrongNumArgs(interp, 1, objv, "matrix"); 163 | return TCL_ERROR; 164 | } 165 | 166 | Tcl_Obj *matrix = objv[1]; 167 | 168 | Tcl_Obj *Z, *T; 169 | 170 | if (doSchur(interp, matrix, &Z, &T) != TCL_OK) { 171 | return TCL_ERROR; 172 | } 173 | 174 | /* return as list */ 175 | Tcl_Obj *result=Tcl_NewObj(); 176 | Tcl_ListObjAppendElement(interp, result, Z); 177 | Tcl_ListObjAppendElement(interp, result, T); 178 | 179 | Tcl_SetObjResult(interp, result); 180 | return TCL_OK; 181 | } 182 | 183 | -------------------------------------------------------------------------------- /generic/schur.h: -------------------------------------------------------------------------------- 1 | /* function definitions for basic linear algebra 2 | * matrix decompositions / equation system solving */ 3 | 4 | #ifndef SCHUR_H 5 | #define SCHUR_H 6 | #include "vectclInt.h" 7 | 8 | /* Compute the Schur form */ 9 | int NumArraySchurCmd(ClientData dummy, Tcl_Interp *interp, 10 | int objc, Tcl_Obj *const *objv); 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /generic/svd.c: -------------------------------------------------------------------------------- 1 | #include "svd.h" 2 | #include "clapack_cutdown.h" 3 | 4 | #define MIN(X, Y) ((X)<(Y) ? X : Y) 5 | #define MAX(X, Y) ((X)>(Y) ? X : Y) 6 | 7 | static int doSVD(Tcl_Interp *interp, Tcl_Obj *matrix, Tcl_Obj **s, Tcl_Obj **U, Tcl_Obj **VT) { 8 | /* Compute singular value decomposition of matrix. 9 | * Return singular values in s. If U and VT are not zero, 10 | * also compute the singular vectors */ 11 | 12 | /* Convert A to VecTcl object */ 13 | NumArrayInfo *info = NumArrayGetInfoFromObj(interp, matrix); 14 | if (!info) { return TCL_ERROR; } 15 | 16 | /* Check that it is a matrix */ 17 | if (info->nDim > 2) { 18 | Tcl_SetResult(interp, "SVD only defined for 2D matrix", NULL); 19 | return TCL_ERROR; 20 | } 21 | 22 | if (ISEMPTYINFO(info)) { 23 | Tcl_SetResult(interp, "SVD of empty matrix undefined", NULL); 24 | } 25 | 26 | /* get matrix dimensions. For a vector, 27 | * set n=1 */ 28 | long int m = info->dims[0]; 29 | long int n = (info->nDim == 1) ? 1 : info->dims[1]; 30 | 31 | int wantvectors = (U!=NULL) && (VT!=NULL); 32 | 33 | char *request = wantvectors ? "A" : "N"; 34 | if (info->type != NumArray_Complex128) { 35 | /* Real-valued matrix, prepare for dgesdd */ 36 | /* create a column-major copy of matrix 37 | * This also converts an integer matrix to double */ 38 | Tcl_Obj *A = NumArrayNewMatrixColMaj(NumArray_Float64, m, n); 39 | NumArrayObjCopy(interp, matrix, A); 40 | 41 | if (wantvectors) { 42 | /* create a real matrix for U and V */ 43 | *U = NumArrayNewMatrixColMaj(NumArray_Float64, m, m); 44 | *VT = NumArrayNewMatrixColMaj(NumArray_Float64, n, n); 45 | } 46 | /* create a real vector for the singular values */ 47 | *s = NumArrayNewVector(NumArray_Float64, MIN(m,n)); 48 | 49 | /* Extract the raw pointers from the VecTcl objects */ 50 | double *Aptr = NumArrayGetPtrFromObj(interp, A); 51 | double *Uptr=NULL, *VTptr=NULL; 52 | if (wantvectors) { 53 | Uptr = NumArrayGetPtrFromObj(interp, *U); 54 | VTptr = NumArrayGetPtrFromObj(interp, *VT); 55 | } 56 | double *sptr = NumArrayGetPtrFromObj(interp, *s); 57 | 58 | /* setup workspace arrays */ 59 | long int lwork = 3*MIN(m,n)*MIN(m,n) + 60 | MAX(MAX(m,n),4*MIN(m,n)*MIN(m,n)+4*MIN(m,n)); 61 | double* work=ckalloc(sizeof(double)*lwork); 62 | long int iworksize=(8*MIN(m,n)); 63 | integer *iwork=ckalloc(sizeof(integer)*iworksize); 64 | 65 | long int lda = m; 66 | /* Leading dimensions. We made a fresh copy for A and 67 | * new matrices U, V, therefore we have the full matrices */ 68 | long int ldu = m; 69 | long int ldvt = n; 70 | long int info; 71 | 72 | 73 | /* Subroutine int dgesdd_(Tcl_Interp *interp, char *jobz, integer *m, integer *n, doublereal * 74 | a, integer *lda, doublereal *s, doublereal *u, integer *ldu, 75 | doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, 76 | integer *iwork, integer *info) */ 77 | 78 | /* call out to dgesdd */ 79 | int result=dgesdd_(interp, request, &m, &n, 80 | Aptr, &lda, sptr, Uptr, 81 | &ldu, VTptr, &ldvt, work, 82 | &lwork, iwork, &info); 83 | 84 | /* free workspace */ 85 | ckfree(work); 86 | ckfree(iwork); 87 | /* A is also overwritten with junk */ 88 | Tcl_DecrRefCount(A); 89 | 90 | if (result != TCL_OK) { 91 | /* release temporary storage for result */ 92 | Tcl_DecrRefCount(*s); 93 | if (wantvectors) { 94 | Tcl_DecrRefCount(*U); 95 | Tcl_DecrRefCount(*VT); 96 | } 97 | return TCL_ERROR; 98 | } 99 | 100 | return TCL_OK; 101 | 102 | 103 | } else { 104 | /* Complex matrix, prepare for ZGESDD */ 105 | /* create a column-major copy of matrix */ 106 | Tcl_Obj *A = NumArrayNewMatrixColMaj(NumArray_Complex128, m, n); 107 | NumArrayObjCopy(interp, matrix, A); 108 | 109 | if (wantvectors) { 110 | /* create a complex matrix for U and V */ 111 | *U = NumArrayNewMatrixColMaj(NumArray_Complex128, m, m); 112 | *VT = NumArrayNewMatrixColMaj(NumArray_Complex128, n, n); 113 | } 114 | 115 | /* create a real vector for the singular values */ 116 | *s = NumArrayNewVector(NumArray_Float64, MIN(m,n)); 117 | 118 | /* Extract the raw pointers from the VecTcl objects */ 119 | NumArray_Complex *Aptr = NumArrayGetPtrFromObj(interp, A); 120 | NumArray_Complex *Uptr = NULL, *VTptr = NULL; 121 | 122 | if (wantvectors) { 123 | Uptr = NumArrayGetPtrFromObj(interp, *U); 124 | VTptr = NumArrayGetPtrFromObj(interp, *VT); 125 | } 126 | 127 | double *sptr = NumArrayGetPtrFromObj(interp, *s); 128 | 129 | /* setup workspace arrays */ 130 | long int lwork=MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n); 131 | NumArray_Complex* work=ckalloc(sizeof(NumArray_Complex)*lwork); 132 | long int lrwork=5*MIN(m,n)*MIN(m,n) + 5*MIN(m,n); 133 | double *rwork = ckalloc(sizeof(double)*lrwork); 134 | long int iworksize=(8*MIN(m,n)); 135 | integer *iwork=ckalloc(sizeof(integer)*iworksize); 136 | long int lda = m; 137 | long int ldu = m; 138 | long int ldvt = n; 139 | long int info; 140 | 141 | /* int zgesdd_(Tcl_Interp *interp, char *jobz, integer *m, integer *n, 142 | doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u, 143 | integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work, 144 | integer *lwork, doublereal *rwork, integer *iwork, integer *info) 145 | */ 146 | /* call out to zgesdd */ 147 | int result=zgesdd_(interp, request, &m, &n, 148 | (doublecomplex *)Aptr, &lda, sptr, (doublecomplex *)Uptr, 149 | &ldu, (doublecomplex *)VTptr, &ldvt, (doublecomplex *)work, 150 | &lwork, rwork, iwork, &info); 151 | 152 | /* free workspace */ 153 | ckfree(rwork); 154 | ckfree(iwork); 155 | ckfree(work); 156 | /* A is also overwritten with junk */ 157 | Tcl_DecrRefCount(A); 158 | 159 | if (result != TCL_OK) { 160 | /* release temporary storage for result */ 161 | Tcl_DecrRefCount(*s); 162 | if (wantvectors) { 163 | Tcl_DecrRefCount(*U); 164 | Tcl_DecrRefCount(*VT); 165 | } 166 | return TCL_ERROR; 167 | } 168 | 169 | return TCL_OK; 170 | } 171 | 172 | } 173 | 174 | int NumArraySVDCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { 175 | if (objc != 2) { 176 | Tcl_WrongNumArgs(interp, 1, objv, "matrix"); 177 | return TCL_ERROR; 178 | } 179 | 180 | Tcl_Obj *matrix = objv[1]; 181 | 182 | Tcl_Obj *s, *U, *VT; 183 | 184 | if (doSVD(interp, matrix, &s, &U, &VT) != TCL_OK) { 185 | return TCL_ERROR; 186 | } 187 | 188 | /* return as list */ 189 | Tcl_Obj *result=Tcl_NewObj(); 190 | Tcl_ListObjAppendElement(interp, result, s); 191 | Tcl_ListObjAppendElement(interp, result, U); 192 | Tcl_ListObjAppendElement(interp, result, VT); 193 | 194 | Tcl_SetObjResult(interp, result); 195 | return TCL_OK; 196 | } 197 | 198 | int NumArraySVD1Cmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { 199 | if (objc != 2) { 200 | Tcl_WrongNumArgs(interp, 1, objv, "matrix"); 201 | return TCL_ERROR; 202 | } 203 | 204 | Tcl_Obj *matrix = objv[1]; 205 | 206 | Tcl_Obj *s; 207 | 208 | if (doSVD(interp, matrix, &s, NULL, NULL) != TCL_OK) { 209 | return TCL_ERROR; 210 | } 211 | 212 | Tcl_SetObjResult(interp, s); 213 | return TCL_OK; 214 | } 215 | -------------------------------------------------------------------------------- /generic/svd.h: -------------------------------------------------------------------------------- 1 | /* function definitions for basic linear algebra 2 | * matrix decompositions / equation system solving */ 3 | 4 | #ifndef SVD_H 5 | #define SVD_H 6 | #include "vectcl.h" 7 | 8 | /* Compute the singular values */ 9 | int NumArraySVD1Cmd(ClientData dummy, Tcl_Interp *interp, 10 | int objc, Tcl_Obj *const *objv); 11 | 12 | /* Compute the SVD A = U*diag(s)*VT */ 13 | int NumArraySVDCmd(ClientData dummy, Tcl_Interp *interp, 14 | int objc, Tcl_Obj *const *objv); 15 | 16 | 17 | #endif 18 | -------------------------------------------------------------------------------- /generic/tcl_xerbla.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "f2c.h" 4 | 5 | /* 6 | From the original manpage: 7 | -------------------------- 8 | XERBLA is an error handler for the LAPACK routines. 9 | It is called by an LAPACK routine if an input parameter has an invalid value. 10 | A message is printed and execution stops. 11 | 12 | Instead of printing a message and stopping the execution, a 13 | ValueError is raised with the message. 14 | 15 | Parameters: 16 | ----------- 17 | srname: Subroutine name to use in error message, maximum six characters. 18 | Spaces at the end are skipped. 19 | info: Number of the invalid parameter. 20 | */ 21 | 22 | /* The Tcl_Interp in a thread-safe way in a call chain from all subroutines 23 | * and return codes are used. Thus we can really just report an error 24 | * as usual within Tcl */ 25 | 26 | int vectcl_xerbla(Tcl_Interp *interp, char *srname, integer *info) 27 | { 28 | const char* format = "%s: parameter number %d is invalid"; 29 | 30 | Tcl_SetObjResult(interp, Tcl_ObjPrintf(format, srname, (int)*info)); 31 | return TCL_ERROR; 32 | } 33 | -------------------------------------------------------------------------------- /generic/uniop.h: -------------------------------------------------------------------------------- 1 | /* to be included with CMD and OP defined 2 | * it defines an elementwise binary operator 3 | * which works by iterating over all elements 4 | * for compatible operands */ 5 | 6 | #define TCLCMDPROC(X) NUMARRAYTPASTER(X,Cmd) 7 | 8 | int CMD(Tcl_Obj* naObj, Tcl_Obj **resultObj); 9 | 10 | MODULE_SCOPE 11 | int TCLCMDPROC(CMD) ( 12 | ClientData dummy, 13 | Tcl_Interp *interp, 14 | int objc, 15 | Tcl_Obj *const *objv) 16 | { 17 | Tcl_Obj *naObj, *resultObj; 18 | int resultcode; 19 | 20 | if (objc != 2) { 21 | Tcl_WrongNumArgs(interp, 1, objv, "numarray"); 22 | return TCL_ERROR; 23 | } 24 | 25 | naObj = objv[1]; 26 | 27 | if (Tcl_ConvertToType(interp, naObj, &NumArrayTclType) != TCL_OK) { 28 | return TCL_ERROR; 29 | } 30 | 31 | resultcode=CMD(naObj, &resultObj); 32 | 33 | Tcl_SetObjResult(interp, resultObj); 34 | 35 | return resultcode; 36 | } 37 | 38 | 39 | int CMD(Tcl_Obj* naObj, Tcl_Obj **resultObj) { 40 | 41 | NumArrayInfo *info, *resultinfo; 42 | NumArraySharedBuffer *resultbuf; 43 | 44 | info = naObj->internalRep.twoPtrValue.ptr2; 45 | 46 | NumArrayIterator it; 47 | NumArrayIteratorInitObj(NULL, naObj, &it); 48 | /* the new shared buffer is in canonical form, 49 | * thus we can simply iterate over it by pointer 50 | * arithmetics. But the input array may be non-canonical 51 | * TODO optimize for canonical case */ 52 | switch (info -> type) { 53 | #ifdef DBLOP 54 | case NumArray_Float64: { 55 | resultinfo = CreateNumArrayInfo(info -> nDim, info -> dims, NATYPE_FROM_C(DBLRES)); 56 | 57 | /* allocate buffer for result */ 58 | resultbuf = NumArrayNewSharedBuffer(resultinfo -> bufsize); 59 | DBLRES *result = (DBLRES*) NumArrayGetPtrFromSharedBuffer(resultbuf); 60 | 61 | const index_t srcpitch=NumArrayIteratorRowPitchTyped(&it); 62 | const index_t length = NumArrayIteratorRowLength(&it); 63 | double* opptr = NumArrayIteratorDeRefPtr(&it); 64 | while (opptr) { 65 | index_t i; 66 | for (i=0; i nDim, info -> dims, NATYPE_FROM_C(INTRES)); 83 | 84 | /* allocate buffer for result */ 85 | resultbuf = NumArrayNewSharedBuffer(resultinfo -> bufsize); 86 | INTRES *result = (INTRES*) NumArrayGetPtrFromSharedBuffer(resultbuf); 87 | 88 | const index_t srcpitch=NumArrayIteratorRowPitchTyped(&it); 89 | const index_t length = NumArrayIteratorRowLength(&it); 90 | NaWideInt* opptr = NumArrayIteratorDeRefPtr(&it); 91 | while (opptr) { 92 | index_t i; 93 | for (i=0; i nDim, info -> dims, NATYPE_FROM_C(CPLXRES)); 110 | 111 | /* allocate buffer for result */ 112 | resultbuf = NumArrayNewSharedBuffer(resultinfo -> bufsize); 113 | CPLXRES *result = (CPLXRES*) NumArrayGetPtrFromSharedBuffer(resultbuf); 114 | 115 | const index_t srcpitch=NumArrayIteratorRowPitchTyped(&it); 116 | const index_t length = NumArrayIteratorRowLength(&it); 117 | NumArray_Complex* opptr = NumArrayIteratorDeRefPtr(&it); 118 | while (opptr) { 119 | index_t i; 120 | for (i=0; itype]); 137 | return TCL_ERROR; 138 | } 139 | 140 | *resultObj=Tcl_NewObj(); 141 | NumArraySetInternalRep(*resultObj, resultbuf, resultinfo); 142 | 143 | return TCL_OK; 144 | } 145 | 146 | #undef CMD 147 | #undef TCLCMDPROC 148 | 149 | #undef INTOP 150 | #undef INTRES 151 | #undef DBLOP 152 | #undef DBLRES 153 | #undef CPLXOP 154 | #undef CPLXRES 155 | -------------------------------------------------------------------------------- /generic/vectclInt.h: -------------------------------------------------------------------------------- 1 | #ifndef VECTCLINT_H 2 | #define VECTCLINT_H 3 | #include 4 | #include "vectcl.h" 5 | 6 | #ifdef DEBUG_REFCOUNT 7 | #include 8 | #define DEBUGPRINTF(X) printf X 9 | #else 10 | #define DEBUGPRINTF(X) 11 | #endif 12 | 13 | /* Token pasting macro */ 14 | #define NUMARRAYTPASTER(X, Y) X##Y 15 | #define NUMARRAYTPASTER3(X, Y, Z) X##Y##Z 16 | #define NUMARRAYTPASTER4(X, Y, Z, W) X##Y##Z##W 17 | 18 | extern const char * NumArray_typename[NumArray_SentinelType+1]; 19 | extern const char * NumArray_typesuffixes[NumArray_SentinelType+1]; 20 | 21 | /* Macros for preprocessor magic 22 | * Convert between C type and numeric array type */ 23 | 24 | #define C_FROM_NATYPE_NumArray_Int NaWideInt 25 | #define C_FROM_NATYPE_NumArray_Bool int 26 | #define C_FROM_NATYPE_NumArray_Int8 int8_t 27 | #define C_FROM_NATYPE_NumArray_Uint8 uint8_t 28 | #define C_FROM_NATYPE_NumArray_Int16 int16_t 29 | #define C_FROM_NATYPE_NumArray_Uint16 uint16_t 30 | #define C_FROM_NATYPE_NumArray_Int32 int32_t 31 | #define C_FROM_NATYPE_NumArray_Uint32 uint32_t 32 | #define C_FROM_NATYPE_NumArray_Int64 int64_t 33 | #define C_FROM_NATYPE_NumArray_Uint64 uint64_t 34 | #define C_FROM_NATYPE_NumArray_Float32 float 35 | #define C_FROM_NATYPE_NumArray_Float64 double 36 | #define C_FROM_NATYPE_NumArray_Complex64 NumArray_ComplexFloat 37 | #define C_FROM_NATYPE_NumArray_Complex128 NumArray_Complex 38 | 39 | #define NATYPE_FROM_C_NaWideInt NumArray_Int 40 | #define NATYPE_FROM_C_int8_t NumArray_Int8 41 | #define NATYPE_FROM_C_uint8_t NumArray_Uint8 42 | #define NATYPE_FROM_C_int16_t NumArray_Int16 43 | #define NATYPE_FROM_C_uint16_t NumArray_Uint16 44 | #define NATYPE_FROM_C_int32_t NumArray_Int32 45 | #define NATYPE_FROM_C_uint32_t NumArray_Uint32 46 | #define NATYPE_FROM_C_int64_t NumArray_Int64 47 | #define NATYPE_FROM_C_uint64_t NumArray_Uint64 48 | #define NATYPE_FROM_C_float NumArray_Float32 49 | #define NATYPE_FROM_C_double NumArray_Float64 50 | #define NATYPE_FROM_C_NumArray_ComplexFloat NumArray_Complex64 51 | #define NATYPE_FROM_C_NumArray_Complex NumArray_Complex128 52 | 53 | 54 | #define C_FROM_NATYPE(X) NUMARRAYTPASTER(C_FROM_NATYPE_, X) 55 | #define NATYPE_FROM_C(X) NUMARRAYTPASTER(NATYPE_FROM_C_, X) 56 | 57 | /* Macro to handle upcasting */ 58 | #define UPCAST(TFROM, TTO, X) NUMARRAYTPASTER4(UPCAST_, TFROM, _, TTO)(X) 59 | 60 | #define UPCAST_NaWideInt_NaWideInt(X) X 61 | #define UPCAST_NaWideInt_double(X) X 62 | #define UPCAST_double_double(X) X 63 | #define UPCAST_NaWideInt_NumArray_Complex(X) NumArray_mkComplex(X, 0.0) 64 | #define UPCAST_double_NumArray_Complex(X) NumArray_mkComplex(X, 0.0) 65 | #define UPCAST_NumArray_Complex_NumArray_Complex(X) X 66 | 67 | #define UPCAST_COMMON(T1, T2) NUMARRAYTPASTER4(UPCAST_COMMON_, T1, _, T2) 68 | #define UPCAST_COMMON_NaWideInt_NaWideInt NaWideInt 69 | #define UPCAST_COMMON_NaWideInt_double double 70 | #define UPCAST_COMMON_double_NaWideInt double 71 | #define UPCAST_COMMON_double_double double 72 | #define UPCAST_COMMON_NaWideInt_NumArray_Complex NumArray_Complex 73 | #define UPCAST_COMMON_NumArray_Complex_NaWideInt NumArray_Complex 74 | #define UPCAST_COMMON_double_NumArray_Complex NumArray_Complex 75 | #define UPCAST_COMMON_NumArray_Complex_double NumArray_Complex 76 | #define UPCAST_COMMON_NumArray_Complex_NumArray_Complex NumArray_Complex 77 | 78 | /* Useful to print formatted error messages */ 79 | #define RESULTPRINTF(X) Tcl_SetObjResult(interp, Tcl_ObjPrintf X) 80 | 81 | extern const Tcl_ObjType NumArrayTclType; 82 | 83 | void NumArrayIncrRefcount(Tcl_Obj* naObj); 84 | void NumArrayDecrRefcount(Tcl_Obj* naObj); 85 | 86 | void NumArrayStripSingletonDimensions(NumArrayInfo *info); 87 | void NumArrayUnshareBuffer(Tcl_Obj *naObj); 88 | int NumArrayIsShared(NumArraySharedBuffer *sharedbuf); 89 | 90 | int NumArrayCompatibleDimensions(NumArrayInfo *info1, NumArrayInfo *info2); 91 | 92 | #define SUBCOMMAND(X) \ 93 | int X(ClientData dummy, Tcl_Interp *interp,\ 94 | int objc, Tcl_Obj *const *objv) 95 | 96 | SUBCOMMAND(NumArrayCreateCmd); 97 | SUBCOMMAND(NumArrayConstFillCmd); 98 | SUBCOMMAND(NumArrayEyeCmd); 99 | SUBCOMMAND(NumArrayInfoCmd); 100 | SUBCOMMAND(NumArrayDimensionsCmd); 101 | SUBCOMMAND(NumArrayShapeCmd); 102 | SUBCOMMAND(NumArrayReshapeCmd); 103 | SUBCOMMAND(NumArrayTransposeCmd); 104 | SUBCOMMAND(NumArrayAdjointCmd); 105 | SUBCOMMAND(NumArraySliceCmd); 106 | SUBCOMMAND(NumArraySetCmd); 107 | SUBCOMMAND(NumArrayGetCmd); 108 | SUBCOMMAND(NumArrayFastCopyCmd); 109 | SUBCOMMAND(NumArrayFastAddCmd); 110 | SUBCOMMAND(NumArrayLinRegCmd); 111 | SUBCOMMAND(NumArrayConvIntCmd); 112 | #define CONVERTER(X) SUBCOMMAND(NumArrayConv ## X ## Cmd); 113 | MAP(CONVERTER, Bool, Int8, Uint8, Int16, Uint16, Int32, Uint32, Int64, Uint64, Float32, Float64, Complex64, Complex128) 114 | #undef CONVERTER 115 | SUBCOMMAND(NumArrayConvDoubleCmd); 116 | SUBCOMMAND(NumArrayConvComplexCmd); 117 | SUBCOMMAND(NumArrayAbsCmd); 118 | SUBCOMMAND(NumArraySignCmd); 119 | SUBCOMMAND(NumArrayRealCmd); 120 | SUBCOMMAND(NumArrayImagCmd); 121 | SUBCOMMAND(NumArrayArgCmd); 122 | SUBCOMMAND(NumArrayConjCmd); 123 | SUBCOMMAND(NumArrayPlusCmd); 124 | SUBCOMMAND(NumArrayMinusCmd); 125 | SUBCOMMAND(NumArrayTimesCmd); 126 | SUBCOMMAND(NumArrayLdivideCmd); 127 | SUBCOMMAND(NumArrayRdivideCmd); 128 | /* relation operators */ 129 | SUBCOMMAND(NumArrayGreaterCmd); 130 | SUBCOMMAND(NumArrayLesserCmd); 131 | SUBCOMMAND(NumArrayGreaterEqualCmd); 132 | SUBCOMMAND(NumArrayLesserEqualCmd); 133 | SUBCOMMAND(NumArrayEqualCmd); 134 | SUBCOMMAND(NumArrayUnequalCmd); 135 | /* boolean operators */ 136 | SUBCOMMAND(NumArrayNotCmd); 137 | SUBCOMMAND(NumArrayAndCmd); 138 | SUBCOMMAND(NumArrayOrCmd); 139 | 140 | SUBCOMMAND(NumArrayBackslashCmd); 141 | SUBCOMMAND(NumArraySlashCmd); 142 | SUBCOMMAND(NumArrayMatrixPowCmd); 143 | SUBCOMMAND(NumArrayReminderCmd); 144 | SUBCOMMAND(NumArrayPowCmd); 145 | SUBCOMMAND(NumArrayMinCmd); 146 | SUBCOMMAND(NumArrayMaxCmd); 147 | SUBCOMMAND(NumArraySetAssignCmd); 148 | SUBCOMMAND(NumArrayPlusAssignCmd); 149 | SUBCOMMAND(NumArrayMinusAssignCmd); 150 | SUBCOMMAND(NumArrayTimesAssignCmd); 151 | SUBCOMMAND(NumArrayLdivideAssignCmd); 152 | SUBCOMMAND(NumArrayRdivideAssignCmd); 153 | SUBCOMMAND(NumArrayPowAssignCmd); 154 | SUBCOMMAND(NumArrayNegCmd); 155 | SUBCOMMAND(NumArrayNegCmd); 156 | SUBCOMMAND(NumArraySinCmd); 157 | SUBCOMMAND(NumArrayCosCmd); 158 | SUBCOMMAND(NumArrayTanCmd); 159 | SUBCOMMAND(NumArrayExpCmd); 160 | SUBCOMMAND(NumArrayLogCmd); 161 | SUBCOMMAND(NumArrayLog10Cmd); 162 | SUBCOMMAND(NumArraySqrtCmd); 163 | SUBCOMMAND(NumArraySinhCmd); 164 | SUBCOMMAND(NumArrayCoshCmd); 165 | SUBCOMMAND(NumArrayTanhCmd); 166 | SUBCOMMAND(NumArrayAsinCmd); 167 | SUBCOMMAND(NumArrayAcosCmd); 168 | SUBCOMMAND(NumArrayAtanCmd); 169 | SUBCOMMAND(NumArrayAsinhCmd); 170 | SUBCOMMAND(NumArrayAcoshCmd); 171 | SUBCOMMAND(NumArrayAtanhCmd); 172 | SUBCOMMAND(NumArrayQRecoCmd); 173 | SUBCOMMAND(NumArraySumCmd); 174 | SUBCOMMAND(NumArrayAxisMinCmd); 175 | SUBCOMMAND(NumArrayAxisMaxCmd); 176 | SUBCOMMAND(NumArrayMeanCmd); 177 | SUBCOMMAND(NumArrayStdCmd); 178 | SUBCOMMAND(NumArrayStd1Cmd); 179 | SUBCOMMAND(NumArrayAllCmd); 180 | SUBCOMMAND(NumArrayAnyCmd); 181 | 182 | #endif 183 | -------------------------------------------------------------------------------- /generic/vexpr.peg: -------------------------------------------------------------------------------- 1 | PEG VMath (Program) 2 | Program <- Sequence; 3 | # A program is a sequence of statements 4 | Sequence <- WS Statement (WS Separator WS Statement)* WS; 5 | Statement <- ForLoop / ForEachLoop / WhileLoop / IfClause / 6 | Assignment / OpAssignment / Expression / Empty; 7 | Empty <- WS; 8 | 9 | # Statements can be assignments, single expressions 10 | # or control constructs 11 | Assignment <- VarSlice ( WS ',' WS VarSlice)* WS '=' WS Expression; 12 | OpAssignment <- VarSlice WS AssignOp WS Expression; 13 | ForEachLoop <- 'for' WSob Var WS '=' WS Expression 14 | WSob '{' Sequence '}'; 15 | ForLoop <- 'for' WSob Var WS '=' WS RangeExpr 16 | WSob '{' Sequence '}'; 17 | WhileLoop <- 'while' WSob Expression WSob '{' Sequence '}'; 18 | 19 | IfClause <- 'if' WSob Expression WSob '{' Sequence '}' 20 | (WSob 'else' WSob '{' Sequence '}')?; 21 | 22 | # Expressions are constructed from additive, multiplicative 23 | # and power operators and may contain references to variables 24 | # and function calls 25 | 26 | Expression <- BoolOrExpr; 27 | BoolOrExpr <- BoolAndExpr (WS OrOp WS BoolAndExpr)*; 28 | BoolAndExpr <- RelExpr (WS AndOp WS RelExpr)*; 29 | 30 | RelExpr <- AddExpr (WS RelOp WS AddExpr)?; 31 | 32 | AddExpr <- Term (WS AddOp WS Term)*; 33 | Term <- ( Factor (WS MulOp WS Factor)* ) / Sign Factor (WS MulOp WS Factor)*; 34 | Factor <- Transpose WS PowOp WS Factor / Transpose; 35 | 36 | Transpose <- Fragment TransposeOp / Fragment; 37 | Fragment <- Number / '(' WS Expression WS ')' / Function / VarSlice/Literal; 38 | 39 | Function <- FunctionName '(' ( WS Expression WS (',' WS Expression WS)* )? ')'; 40 | 41 | VarSlice <- Var ( WS '[' WS SliceExpr ( ',' WS SliceExpr )* WS ']' )?; 42 | SliceExpr <- Expression WS (':' WS Expression WS ( ':' WS Expression )? )? / ':'; 43 | RangeExpr <- Expression WS ':' WS Expression (WS ':' WS Expression )?; 44 | 45 | Literal <- '{' WS (( ComplexNumber / Literal ) (WSob (ComplexNumber / Literal))* WS)? '}'; 46 | ComplexNumber <- Sign? RealNumber ( Sign ImaginaryNumber)?; 47 | leaf: TransposeOp <- "'"; 48 | leaf: AssignOp <- '=' / '+=' / '-=' / '.+=' / '.-=' / '.*=' / './=' / '.^=' / '.**='; 49 | leaf: RealNumber <- + ('.' + )? ( ('e' / 'E' ) ('+' / '-') ? + )?; 50 | leaf: ImaginaryNumber <- + ('.' + )? ( ('e' / 'E' ) ('+' / '-') ? + )? ('i' / 'I'); 51 | leaf: Number <- ImaginaryNumber / RealNumber; 52 | leaf: Sign <- '+' / '-' / '!'; 53 | leaf: Var <- Identifier; 54 | leaf: FunctionName <- Identifier; 55 | leaf: RelOp <- '==' / '<=' / '>=' / '<' / '>' / '!='; 56 | leaf: AndOp <- '&&'; 57 | leaf: OrOp <- '||'; 58 | leaf: MulOp <- '*' / '%' / '/' / '.*' / './' / '\\'; 59 | leaf: AddOp <- '+' / '-' / '.+' / '.-'; 60 | leaf: PowOp <- '^' / '**' / '.^' / '.**'; 61 | leaf: Identifier <- ('_' / '::' / ) ('_' / '::' / )* ; 62 | # requiring :: to be in pairs is crucial; otherwise 63 | # we can't parse SliceExpr correctly. ':' and '1::' would be ambiguous 64 | # 65 | # facultative whitespace 66 | void: WS <- (('\\' EOL) / (!EOL ))*; 67 | # obligatory whitespace 68 | void: WSob <- (('\\' EOL) / (!EOL ))+; 69 | void: Separator <- Comment? EOL / ';'; 70 | void: Comment <- '#' (!EOL .)*; 71 | void: EOL <- '\n'; 72 | 73 | END; 74 | 75 | -------------------------------------------------------------------------------- /generic/vmparser.h: -------------------------------------------------------------------------------- 1 | #ifndef VMPARSER_H 2 | #define VMPARSER_H 3 | int Vmparser_Init(Tcl_Interp* interp); 4 | #endif 5 | 6 | -------------------------------------------------------------------------------- /gentest.tcl: -------------------------------------------------------------------------------- 1 | proc gentest {topic subject code} { 2 | # convenience to generate a test case 3 | # for exact comparison 4 | set fd [open tests/nrcache r] 5 | set nrcache [read $fd] 6 | close $fd 7 | 8 | set returncode [catch $code result] 9 | set nr [dict get [dict incr nrcache $subject] $subject] 10 | set test "test $topic $subject-$nr -body \{\n" 11 | append test "\t[string map {\n \n\t} $code]\n" 12 | append test "\} -result [list $result]" 13 | if {$returncode} { 14 | append test " -returnCodes $returncode" 15 | } 16 | append test "\n" 17 | 18 | set fd [open tests/$topic.test a] 19 | puts $fd $test 20 | close $fd 21 | 22 | set fd [open tests/nrcache w] 23 | puts -nonewline $fd $nrcache 24 | close $fd 25 | 26 | return $test 27 | } 28 | -------------------------------------------------------------------------------- /license.terms: -------------------------------------------------------------------------------- 1 | This software is copyrighted by the Christian Gollwitzer, Scriptics Corporation, 2 | and other parties. The following terms apply to all files associated with the 3 | software unless explicitly disclaimed in individual files. 4 | 5 | The authors hereby grant permission to use, copy, modify, distribute, 6 | and license this software and its documentation for any purpose, provided 7 | that existing copyright notices are retained in all copies and that this 8 | notice is included verbatim in any distributions. No written agreement, 9 | license, or royalty fee is required for any of the authorized uses. 10 | Modifications to this software may be copyrighted by their authors 11 | and need not follow the licensing terms described here, provided that 12 | the new terms are clearly indicated on the first page of each file where 13 | they apply. 14 | 15 | IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY 16 | FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES 17 | ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY 18 | DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE 19 | POSSIBILITY OF SUCH DAMAGE. 20 | 21 | THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, 22 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, 23 | FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE 24 | IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE 25 | NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR 26 | MODIFICATIONS. 27 | 28 | GOVERNMENT USE: If you are acquiring this software on behalf of the 29 | U.S. government, the Government shall have only "Restricted Rights" 30 | in the software and related documentation as defined in the Federal 31 | Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you 32 | are acquiring the software on behalf of the Department of Defense, the 33 | software shall be classified as "Commercial Computer Software" and the 34 | Government shall have only "Restricted Rights" as defined in Clause 35 | 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the 36 | authors grant the U.S. Government and others acting in its behalf 37 | permission to use and distribute the software in accordance with the 38 | terms specified in this license. 39 | -------------------------------------------------------------------------------- /lsqbench.tcl: -------------------------------------------------------------------------------- 1 | lappend auto_path [file dirname [info script]] 2 | package require vectcl 3 | package require math::linearalgebra 4 | namespace import math::linearalgebra::* 5 | namespace import vectcl::vexpr 6 | 7 | # create data in lists x and y 8 | set x {}; set y {} 9 | for {set i 0} {$i<1000} {incr i} { 10 | set xel [expr {($i-200.0)/300}] 11 | lappend x $xel 12 | lappend xsq [expr {$xel**2}] 13 | lappend y [expr {1.25+$xel+0.23*$xel**2+rand()}] 14 | } 15 | 16 | # fit a+b*x+c*x^2 to the data 17 | # using matrx decomposition in Tcl(lib) and VecTcl 18 | proc solveTcl {x y} { 19 | upvar 1 xsq xsq 20 | set n [llength $x] 21 | if {1} { 22 | # doesn't work, because mul is missing 23 | set A [mkMatrix $n 3] 24 | setcol A 0 [mkVector $n 1.0] 25 | setcol A 1 $x 26 | setcol A 2 $xsq 27 | } else { 28 | 29 | # create matrix 30 | foreach xel $x { 31 | lappend A [list 1.0 $xel [expr {$xel**2}]] 32 | } 33 | } 34 | # solve least squares problem 35 | leastSquaresSVD $A $y 36 | } 37 | 38 | proc solveVecTcl {x y} { 39 | vexpr { 40 | A=hstack(1,x,x.^2) 41 | A \ y 42 | } 43 | } 44 | 45 | proc solveVecTclSlice {x y} { 46 | vexpr { 47 | n=llength(x) 48 | A=ones(n,3) 49 | A[:,1]=x 50 | A[:,2]=x.^2 51 | A \ y 52 | } 53 | } 54 | 55 | 56 | -------------------------------------------------------------------------------- /pkgIndex.tcl.in: -------------------------------------------------------------------------------- 1 | # 2 | # Tcl package index file 3 | # 4 | package ifneeded @PACKAGE_NAME@ @PACKAGE_VERSION@ \ 5 | "load -global [list [file join $dir @PKG_LIB_FILE@]] @PACKAGE_NAME@; 6 | source [list [file join $dir vexpr.tcl]]" 7 | -------------------------------------------------------------------------------- /tcl86_vectcl.patch: -------------------------------------------------------------------------------- 1 | diff -ru tcl8.6.4_orig/generic/tclInt.h tcl8.6/generic/tclInt.h 2 | --- tcl8.6.4_orig/generic/tclInt.h 2015-07-22 11:12:05.678022931 +0200 3 | +++ tcl8.6/generic/tclInt.h 2015-07-22 11:12:42.662206326 +0200 4 | @@ -2686,7 +2686,7 @@ 5 | MODULE_SCOPE const Tcl_ObjType tclDoubleType; 6 | MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; 7 | MODULE_SCOPE const Tcl_ObjType tclIntType; 8 | -MODULE_SCOPE const Tcl_ObjType tclListType; 9 | +MODULE_SCOPE Tcl_ObjType tclListType; 10 | MODULE_SCOPE const Tcl_ObjType tclDictType; 11 | MODULE_SCOPE const Tcl_ObjType tclProcBodyType; 12 | MODULE_SCOPE const Tcl_ObjType tclStringType; 13 | diff -ru tcl8.6.4_orig/generic/tclListObj.c tcl8.6/generic/tclListObj.c 14 | --- tcl8.6.4_orig/generic/tclListObj.c 2015-07-22 11:12:05.694023011 +0200 15 | +++ tcl8.6/generic/tclListObj.c 2015-07-22 11:12:42.674206386 +0200 16 | @@ -38,7 +38,7 @@ 17 | * storage to avoid an auxiliary stack. 18 | */ 19 | 20 | -const Tcl_ObjType tclListType = { 21 | +Tcl_ObjType tclListType = { 22 | "list", /* name */ 23 | FreeListInternalRep, /* freeIntRepProc */ 24 | DupListInternalRep, /* dupIntRepProc */ 25 | @@ -470,7 +470,7 @@ 26 | *objvPtr = NULL; 27 | return TCL_OK; 28 | } 29 | - result = SetListFromAny(interp, listPtr); 30 | + result = Tcl_ConvertToType(interp, listPtr, &tclListType); 31 | if (result != TCL_OK) { 32 | return result; 33 | } 34 | @@ -579,7 +579,7 @@ 35 | Tcl_SetListObj(listPtr, 1, &objPtr); 36 | return TCL_OK; 37 | } 38 | - result = SetListFromAny(interp, listPtr); 39 | + result = Tcl_ConvertToType(interp, listPtr, &tclListType); 40 | if (result != TCL_OK) { 41 | return result; 42 | } 43 | @@ -743,7 +743,7 @@ 44 | *objPtrPtr = NULL; 45 | return TCL_OK; 46 | } 47 | - result = SetListFromAny(interp, listPtr); 48 | + result = Tcl_ConvertToType(interp, listPtr, &tclListType); 49 | if (result != TCL_OK) { 50 | return result; 51 | } 52 | @@ -796,7 +796,7 @@ 53 | *intPtr = 0; 54 | return TCL_OK; 55 | } 56 | - result = SetListFromAny(interp, listPtr); 57 | + result = Tcl_ConvertToType(interp, listPtr, &tclListType); 58 | if (result != TCL_OK) { 59 | return result; 60 | } 61 | @@ -869,7 +869,7 @@ 62 | } 63 | Tcl_SetListObj(listPtr, objc, NULL); 64 | } else { 65 | - int result = SetListFromAny(interp, listPtr); 66 | + int result = Tcl_ConvertToType(interp, listPtr, &tclListType); 67 | 68 | if (result != TCL_OK) { 69 | return result; 70 | @@ -1627,7 +1627,7 @@ 71 | } 72 | return TCL_ERROR; 73 | } 74 | - result = SetListFromAny(interp, listPtr); 75 | + result = Tcl_ConvertToType(interp, listPtr, &tclListType); 76 | if (result != TCL_OK) { 77 | return result; 78 | } 79 | -------------------------------------------------------------------------------- /tclconfig/README.txt: -------------------------------------------------------------------------------- 1 | These files comprise the basic building blocks for a Tcl Extension 2 | Architecture (TEA) extension. For more information on TEA see: 3 | 4 | http://www.tcl.tk/doc/tea/ 5 | 6 | This package is part of the Tcl project at SourceForge, and latest 7 | sources should be available there: 8 | 9 | http://tcl.sourceforge.net/ 10 | 11 | This package is a freely available open source package. You can do 12 | virtually anything you like with it, such as modifying it, redistributing 13 | it, and selling it either in whole or in part. 14 | 15 | CONTENTS 16 | ======== 17 | The following is a short description of the files you will find in 18 | the sample extension. 19 | 20 | README.txt This file 21 | 22 | install-sh Program used for copying binaries and script files 23 | to their install locations. 24 | 25 | tcl.m4 Collection of Tcl autoconf macros. Included by a package's 26 | aclocal.m4 to define TEA_* macros. 27 | -------------------------------------------------------------------------------- /tea/app_config_options.txt: -------------------------------------------------------------------------------- 1 | [section {Appendix B. Configuration options}] 2 | 3 | The [emph configure] script as generated by Autoconf will support a 4 | number of standard configuration options as well as any that you define 5 | for your extension via the [emph AC_ARG_WITH] and [emph AC_ARG_ENABLE] 6 | macros. 7 | [para] 8 | The table below describes the standard configuration options (most of the 9 | text is copied from B. Welch's book "Practical Tcl and Tk programming", 3rd edition) 10 | 11 | [list_begin bullet] 12 | 13 | [bullet] 14 | --prefix=[emph dir] 15 | [nl] 16 | Defines the root of the installation directory - default: /usr/local. 17 | 18 | [bullet] 19 | --exec-prefix=[emph dir] 20 | [nl] 21 | Defines the root of the installation directory for platform-specific files 22 | - default: the value of "--prefix". 23 | 24 | [bullet] 25 | --enable-gcc/--disable-gcc (default) 26 | [nl] 27 | Use the [emph gcc] compiler instead of the native (enable) or use 28 | the native compiler (disable). 29 | 30 | [bullet] 31 | --enable-shared (default)/--disable-shared 32 | [nl] 33 | Compile and link to get [emph {shared/dynamic}] libraries (enable) or compile and link 34 | to get [emph {archive/static}] libraries (disable). 35 | 36 | [bullet] 37 | --enable-symbols/--disable-symbols (default) 38 | [nl] 39 | Compile and link for debugging (enable) or compile and link without debugging (disable). 40 | 41 | [bullet] 42 | --enable-threads/--disable-threads (default) 43 | [nl] 44 | Turn multithreading support on (enable) or off (disable). 45 | 46 | [bullet] 47 | --with-tcl=[emph dir] 48 | [nl] 49 | Specifies the directory where Tcl was built (especially important if you build against 50 | a number of Tcl versions or for more than one platform) 51 | 52 | [bullet] 53 | --with-tk=[emph dir] 54 | [nl] 55 | Specifies the directory where Tk was built 56 | 57 | [bullet] 58 | --with-tclinclude=[emph dir] 59 | [nl] 60 | Specifies the directory where the Tcl include files can be found (notably: tcl.h) 61 | 62 | [bullet] 63 | --with-tcllib=[emph dir] 64 | [nl] 65 | Specifies the directory where the Tcl libraries can be found (notably: libtclstubs.a) 66 | 67 | [bullet] 68 | --with-x11include=[emph dir] 69 | [nl] 70 | Specifies the directory where the X11 include files (such as X11.h) can be found (especially important 71 | if these are not found in one of the usual places) 72 | 73 | [bullet] 74 | --with-x11lib=[emph dir] 75 | [nl] 76 | Specifies the directory where the X11 libraries (e.g. libX11.so) can be found 77 | 78 | [list_end] 79 | 80 | Note that all of these options come with reasonable defaults, so that you only 81 | have to worry about them when the configure script terminates with some kind of 82 | error. 83 | -------------------------------------------------------------------------------- /tea/app_makefiles.txt: -------------------------------------------------------------------------------- 1 | [section {Appendix A. Explanation of make files and the make utility}] 2 | 3 | If you are not familiar with the [emph make] program, here is a brief 4 | explanation of it. In some of its features it is very similar to 5 | MicroSoft's Visual Studio or other [emph {integrated development environments}]: 6 | it processes descriptions of how to create a program from its 7 | sources and does so in an efficient way. In fact, many IDE's use the 8 | [emph {make}] utility in some form or other underneath. 9 | 10 | [para] 11 | The main difference between the [emph make] utility and most, "modern" 12 | IDE's is that [emph make] does not itself manage the description, the 13 | so-called [emph {make file}]. This is left to the programmer. Another 14 | difference is that [emph make] can be used for almost any task where 15 | files need to be built 16 | from other files using some program, in other words it is very flexible. 17 | 18 | [para] 19 | [emph {A small example}] 20 | [para] 21 | 22 | So far the introduction to [emph make]. Let us now describe how 23 | [emph make] does the 24 | job it is supposed to do, using the following sample program: 25 | 26 | [para] 27 | The program "sample" is built from two C source files, sample.c and 28 | utils.c. The first source file includes a header file utils.h, which 29 | contains the interface to the functions in utils.c. 30 | 31 | [para] 32 | Now changes to any of these files mean that the whole program has to be 33 | rebuilt. For this small program, we could easily type the command: 34 | [example { 35 | cc -o sample sample.c utils.c 36 | }] 37 | 38 | (or something similar, depending on the compiler you want to use). This 39 | would recompile the entire source and relink the program against all its 40 | parts. 41 | 42 | [para] 43 | Now: 44 | 45 | [list_begin bullet] 46 | 47 | [bullet] 48 | If only utils.c has changed, then it is a waste of time to recompile 49 | sample.c. 50 | 51 | [bullet] 52 | If the header file "utils.h" has changed, recompiling both is required, 53 | as the prototype of a function may have changed or something else that 54 | is vital to the functions in "utils.c". Only this is not clear at all 55 | from the command we just typed: the dependence of the two source files 56 | on this header file is hidden inside the sources! 57 | 58 | [list_end] 59 | 60 | This is what the [emph make] utility would do, when properly instructed: 61 | 62 | [list_begin bullet] 63 | 64 | [bullet] 65 | The file "sample" (our executable program) and others are defined 66 | as "targets": things for the [emph make] utility to examine. 67 | 68 | [bullet] 69 | The file "sample" depends on two "object files" (the results of 70 | a compilation): 71 | 72 | [list_begin bullet] 73 | [bullet] 74 | sample.o 75 | [bullet] 76 | utils.o 77 | [list_end] 78 | 79 | If any of these files is out of date, then the program is out of date. 80 | 81 | [bullet] 82 | So check if these two files are out of date, by checking their 83 | dependencies: 84 | 85 | [list_begin bullet] 86 | [bullet] 87 | sample.o depends on sample.c and utils.h (because sample.c uses 88 | that header file) 89 | [bullet] 90 | in a similar way, utils.o depends on utils.c and utils.h. 91 | By the same reasoning, check these three files. 92 | [list_end] 93 | 94 | [bullet] 95 | These files are source files and header files, we have edited these 96 | files manually, they can not be created from other files. So, this 97 | is the end of that step in the reasoning process. 98 | [bullet] 99 | The object files sample.o and utils.o are out of date if the three 100 | files are newer: 101 | 102 | [list_begin bullet] 103 | [bullet] 104 | sample.o is out of date if sample.c or utils.h is newer than this file. 105 | Then use the rule that belongs to sample.o to rebuild it 106 | [bullet] 107 | utils.o is out of date if utils.c or utils.h is newer than this file. 108 | Again: use the rule that belongs to utils.o to rebuild that. 109 | [list_end] 110 | 111 | [bullet] 112 | Now the two files that our program depends on are up to date. 113 | The program itself clearly is not. So, relink that program. 114 | 115 | [list_end] 116 | 117 | The makefile might look like this: 118 | [example { 119 | sample->:->sample.o utils.o 120 | ->cc -o sample sample.o utils.o 121 | 122 | sample.o->:->sample.c utils.h 123 | ->cc -c sample.c 124 | 125 | utils.o->:->utils.c utils.h 126 | ->cc -c utils.c 127 | }] 128 | (the symbol "->" indicates a tab character - this is essential in makefiles, 129 | as it is used to identify what lines belong together) 130 | 131 | [para] 132 | This is a very simple makefile, in practice programs that are maintained with 133 | makefiles are much larger, you need to take of building the documentation, 134 | libraries, of installing the files at the proper location and so on. To make 135 | things worse: many compilers use different options to specify similar 136 | tasks and operating systems require different libraries (or put the 137 | libraries in different places). 138 | 139 | [para] 140 | To help manage the makefiles, the [emph autoconf] utility was created. This 141 | utility prepares the correct makefile from a given template, using a 142 | complicated but relatively easy to use configuration script. 143 | -------------------------------------------------------------------------------- /tea/codingstyle.txt: -------------------------------------------------------------------------------- 1 | [section {Chapter 3. RECOMMENDED CODING STYLE}] 2 | 3 | We do not want to say too much about coding style, and certainly we do 4 | not want to prescribe any particular style. Just make sure for yourself 5 | that: 6 | [list_begin bullet] 7 | 8 | [bullet] 9 | you have added appropriate and clear comments to the code 10 | 11 | [bullet] 12 | you have used well-defined and clear constructs, not too many C macros 13 | and such, which can make it difficult to understand the code 14 | 15 | [bullet] 16 | you do not rely on compiler-specific features (extensions to the 17 | standard language that are very uncommon for instance) 18 | 19 | [bullet] 20 | you dare show it to other people, as other people will definitely see 21 | it and read your code. 22 | 23 | [list_end] 24 | 25 | A very good example of coding style is Tcl itself: the code is 26 | well-documented, the layout is clean, with a bit of study you can really 27 | understand what is going on. More textual descriptions of a 28 | recommended coding style for C and for Tcl can be found in: 29 | .... 30 | 31 | [para] 32 | We can add a few conventions here, almost trivial, perhaps, but since 33 | they are very often used, it will help people to understand your code 34 | better: 35 | 36 | [list_begin bullet] 37 | 38 | [bullet] 39 | For the use of namespaces (highly recommended to avoid name clashes), 40 | read the tutorial by Will Duquette. 41 | 42 | [bullet] 43 | Avoid the use of global variables, use namespace variables instead. 44 | 45 | [bullet] 46 | For "public" routines use names that start with a lowercase letter 47 | and add these to a [namespace export] command 48 | 49 | [bullet] 50 | For "private" routines use names that start with an uppercase letter 51 | 52 | [list_end] 53 | 54 | If you implement your extension in C, remember to use the Tcl_Obj 55 | interface: it is much faster than the old pre-8.0 interface that used 56 | strings. This means that you may need to pay quite some attention to 57 | issues like reference counts, but it is certainly worth the effort. 58 | -------------------------------------------------------------------------------- /tea/introduction.txt: -------------------------------------------------------------------------------- 1 | [comment { 2 | Remarks: 3 | - The sample extension uses the string interface 4 | - Is the sample extension in CVS up to date? 5 | - What makes tkimg special - its own stubs - why? 6 | }] 7 | 8 | [description] 9 | The Tcl Extension Architecture is meant to help developers set up a 10 | standardised environment so that any user can compile the extension 11 | without any knowledge of the extension. This way a lot of work can be 12 | saved. 13 | 14 | This document describes the various aspects of TEA in detail. 15 | 16 | [section {Chapter 1. OVERVIEW}] 17 | 18 | TEA relies heavily on the GNU tool [emph autoconf]. An intimate 19 | knowledge of this tool is, fortunately, not required, but for complicated 20 | extensions that rely on many things specific to a particular platform, 21 | it may be necessary to add your own checks and procedures to the 22 | existing TEA macro library. 23 | 24 | The structure of this document is as follows: 25 | [sectref {Chapter 2. DESIGN AND CODING}] describes the typical 26 | organisation in files and directories of an extension. 27 | 28 | [para] 29 | [sectref {Chapter 3. RECOMMENDED CODING STYLE}] holds information 30 | about what you should and should not do when coding an extension. 31 | 32 | [para] 33 | [sectref {Chapter 4. TCL PACKAGES}] highlights the package mechanism 34 | that is used by Tcl, whereas [sectref {Chapter 5. TCL STUBS}] explains 35 | the stubs mechanism, important for creating compiled extensions that are 36 | independent of the particular Tcl version. 37 | 38 | [para] 39 | [sectref {Chapter 6. CONFIGURE AND MAKE FILES}] is perhaps the most 40 | important chapter, as this describes how to create the input for the 41 | [emph autoconf] tool. 42 | 43 | [para] 44 | The subjects of [sectref {Chapter 7. WRITING AND RUNNING TESTS}] and 45 | [sectref {Chapter 8. DOCUMENTATION}] may not among most programmers' 46 | favourites, but they are very important to users. And everybody at some 47 | point is a user! 48 | 49 | [para] 50 | [sectref {Appendix A. Explanation of make files and the make utility}] 51 | is meant especially for those programmers not familiar to 52 | make files, because their development environment shields the 53 | complexities from them. 54 | -------------------------------------------------------------------------------- /tea/stubs.txt: -------------------------------------------------------------------------------- 1 | [section {Chapter 5. TCL STUBS}] 2 | 3 | The highly recommended way of using the Tcl and Tk libraries in a 4 | compiled extension is via [emph stubs]. Stubs allow you to compile and 5 | link an extension and use it with any (later) version of Tcl/Tk. If you 6 | do not, then the libraries can only be used with a very specific version 7 | of Tcl/Tk. This chapter provides some information about what the 8 | advantages and disadvantages are of using stubs. 9 | 10 | [para] 11 | It may seem intimidating at first, but the stubs mechanism in Tcl 12 | (available since version 8.1) is actually very simple - from the point 13 | of view of the programmer: 14 | [list_begin bullet] 15 | 16 | [bullet] 17 | You use the call to Tcl_InitStubs() in the initialisation routine 18 | (see the previous chapter) 19 | 20 | [bullet] 21 | You define a macro USE_TCL_STUBS when compiling the code 22 | 23 | [bullet] 24 | You link against the Tcl and Tk stubs library, instead of the actual 25 | libraries. 26 | 27 | [list_end] 28 | 29 | (Needless to say that most is automatically taken care of by the TEA.) 30 | 31 | [para] 32 | Here is what stubs are all about: rather than using the functions in the 33 | Tcl/Tk libraries directly, you access them via a pointer. The actual 34 | code that is involved is hidden from you via C macros, so you have 35 | nothing to worry about, except for the USE_TCL_STUBS macro and the 36 | proper initialisation. More information can be found in ... 37 | 38 | [para] 39 | The limitations of using stubs are that you can only use the Tcl 40 | functions that are publically available in the stub table (see for 41 | details the header files tcl.h and tk.h). You can not use the private 42 | functions (found in the other header files), but this is a bad idea in 43 | the first place, because the interface to these functions may change 44 | from one release to the next - they are simply not meant for use outside 45 | the Tcl library itself. 46 | 47 | [para] 48 | The advantages of stubs are plenty: 49 | 50 | [list_begin bullet] 51 | 52 | [bullet] 53 | You can compile and link the extension against, say, Tcl 8.3 and use 54 | it in Tcl 8.5. That is: the libraries remain useful. 55 | 56 | [bullet] 57 | It is thus also practical to provide binary versions only (if you want 58 | or need to keep the source code secret) 59 | 60 | [bullet] 61 | Stub-enabled extensions can be used in Tclkit, as this relies heavily 62 | on the stub mechanism. 63 | 64 | [list_end] 65 | 66 | To summarise: 67 | [para] 68 | When you use the TEA, then the only thing you need to take care of in 69 | your code, is that the initialisation routine calls Tcl_InitStubs(). 70 | 71 | [para] 72 | Using stubs gives benefits both to you and the users of your extension 73 | that can not be had in another way. 74 | 75 | 76 | [section {Providing your own stubs}] 77 | 78 | A more complicated situation arises when your extension itself defines a 79 | stubs library. This was discussed in some length in Chapter 2. The 80 | advantage is that your functions can be used at the C level too and 81 | would form a veritable extension to the Tcl/Tk API. 82 | 83 | [para] 84 | In the build step this means that besides the ordinary shared object 85 | or DLL also a stubs library must be created. The process is almost 86 | automatic, except that you have to tell which functions are to be made 87 | available in the stubs library (via the .decls file) and you have to 88 | make some provisions in the TEA configuration and make files. 89 | 90 | [para] 91 | If the functions of your extension are to be registered in the Tcl or Tk 92 | library, as is the case with tkimg that provides new formats for the 93 | photo command, then it is necessary or at least highly recommended that 94 | you provide them via the stubs mechanism. 95 | -------------------------------------------------------------------------------- /tea/toman.tcl: -------------------------------------------------------------------------------- 1 | # Small script to assemble the separate chapters to a single file 2 | # 3 | proc putfile {filename} { 4 | set infile [open $filename] 5 | puts $::outfile [read $infile] 6 | close $infile 7 | } 8 | 9 | set outfile [open "teadoc.man" "w"] 10 | 11 | puts $outfile \ 12 | {[manpage_begin {TEA documentation} n 0.2] 13 | [moddesc TEA] 14 | [titledesc {TEA documentation}]} 15 | 16 | putfile introduction.txt 17 | putfile design.txt 18 | putfile codingstyle.txt 19 | putfile packages.txt 20 | putfile stubs.txt 21 | putfile makefiles.txt 22 | putfile writingtests.txt 23 | putfile writingdocs.txt 24 | putfile app_makefiles.txt 25 | putfile app_config_options.txt 26 | 27 | puts $outfile {[manpage_end]} 28 | close $outfile 29 | 30 | -------------------------------------------------------------------------------- /tea/writingdocs.txt: -------------------------------------------------------------------------------- 1 | [section {Chapter 8. DOCUMENTATION}] 2 | 3 | It may seem a heavy burden for many a programmer, but documentation 4 | is necessary, even though one sometimes gets the impression (quite 5 | wrongly of course, but still) that no user ever bothers to read it. 6 | 7 | [para] 8 | Besides proper comments in the code, we need a guide for users to fall 9 | back on. Traditionally for Tcl/Tk this has been in the form of 10 | UNIX-style man pages: 11 | 12 | [list_begin bullet] 13 | 14 | [bullet] 15 | A short introduction to the command 16 | 17 | [bullet] 18 | A list of commands that one can use 19 | 20 | [bullet] 21 | One or more sections with explanations 22 | 23 | [list_end] 24 | 25 | This is a format that works well for more or less experienced users - 26 | they use the man page as a reference manual. On the other hand, new 27 | users may find them a bit awkward, as a lot of background is 28 | usually assumed. 29 | 30 | [para] 31 | For most extensions, it will suffice to use the classical man page 32 | format with perhaps some more explanation of what the extension is all 33 | about and some more examples and elaborated code fragments than usual. 34 | 35 | [para] 36 | To help with writing the documentation, we strongly suggest you use the 37 | so-called [emph doctools] that are now part of the standard Tcl applications. 38 | The basic idea of doctools is simple: 39 | 40 | [list_begin bullet] 41 | 42 | [bullet] 43 | You write the text for the man page using doctools' macros 44 | 45 | [bullet] 46 | These markup macros can be regarded as embedded Tcl commands and 47 | provide the markup system with clues as to how to format the text 48 | (many of the macros represent [emph semantic] clues, instead of mere style 49 | information) 50 | 51 | [bullet] 52 | The doctools application can then process this text and turn it into 53 | any of a number of formats, such as HTML but also nroff and TMML (Tcl 54 | Manual Markup Language). 55 | 56 | [bullet] 57 | This way, one single source suffices to generate all kinds of output 58 | files, suitable for most online documentation systems. 59 | 60 | [list_end] 61 | 62 | Here is a small example of such an input file: 63 | [example { 64 | ...... 65 | }] 66 | 67 | This file can be processed by the doctools application, to give an 68 | HTML-file that is rendered like this: 69 | 70 | [example { 71 | /picture/ ?? 72 | }] 73 | 74 | [section {Short overview of the macros supported by doctools}] 75 | 76 | [para] 77 | [lb]arg $name[rb] 78 | - argument in a [lb]call[rb] statement 79 | [para] 80 | 81 | [lb]arg_def $type $name $intent[rb] 82 | - description of the argument, what type it is (widget, integer, list, 83 | ...), its name and whether it simply passed to the command (in) 84 | or gets set as well (out or in/out) 85 | [para] 86 | 87 | [lb]bullet[rb] 88 | - start a new item in a bullet list 89 | [para] 90 | 91 | [lb]call $cmd $args[rb] 92 | - define a command (its argument list; the command gets added to the 93 | synopsis) 94 | [para] 95 | 96 | [lb]cmd $name[rb] 97 | - name of the command (first argument for [lb]call[rb]) 98 | [para] 99 | 100 | [lb]comment $text[rb] 101 | - add comments to the original, does not show up in the output 102 | [para] 103 | 104 | [lb]copyright $name[rb] 105 | - insert a copyright string at the end of the rendered document 106 | [para] 107 | 108 | [lb]description[rb] 109 | - start the man page section DESCRIPTION (note: this section is required 110 | at the beginning of the document) 111 | [para] 112 | 113 | [lb]emph $text[rb] 114 | - show the given text as emphasized (typically italic) 115 | [para] 116 | 117 | [lb]example $example[rb] 118 | - insert preformatted text that serves as an example for the commands 119 | being discussed 120 | [para] 121 | 122 | [lb]keywords $args[rb] 123 | - add the keywords given in the variable argument list to the end of the 124 | document 125 | [para] 126 | 127 | [lb]list_begin arg[rb] 128 | - start a list of arguments (after a corresponding [lb]call[rb] command) 129 | [para] 130 | 131 | [lb]list_begin bullet[rb] 132 | - start a bullet list 133 | [para] 134 | 135 | [lb]list_begin definitions[rb] 136 | - start a definitions list 137 | [para] 138 | 139 | [lb]list_begin opt[rb] 140 | - start a list of options 141 | [para] 142 | 143 | [lb]list_end[rb] 144 | - end the current list, brackets [lb]list_begin[rb] 145 | [para] 146 | 147 | [lb]manpage_begin $name $section $version[rb] 148 | - indicate the start of the manual page with the name of the 149 | module/package/extension, the section of the manual pages it should go 150 | into (always "n") and the version number 151 | [para] 152 | 153 | [lb]manpage_end[rb] 154 | mandatory end of the man page, brackets the [lb]manpage_begin[rb] command 155 | [para] 156 | 157 | [lb]moddesc $name[rb] 158 | - identify the module 159 | [para] 160 | 161 | [lb]nl[rb] 162 | - put a break in the flowing text. Useable only within lists 163 | [para] 164 | 165 | [lb]opt_def $keyword $type[rb] 166 | - the keyword for an option (without the leading minus sign) and the 167 | expected value type (if any) 168 | [para] 169 | 170 | [lb]para[rb] 171 | - start a new paragraph 172 | [para] 173 | 174 | [lb]require $package $version[rb] 175 | - insert a "package require" command in the synopsis of the man page to 176 | indicate the dependencies 177 | [para] 178 | 179 | [lb]section $title[rb] 180 | - start a new section, the title is traditionally given in capitals 181 | [para] 182 | 183 | [lb]titledesc $title[rb] 184 | - give the man page a proper title 185 | 186 | 187 | [section REFERENCES] 188 | 189 | [list_begin bullet] 190 | 191 | [bullet] 192 | Will Duquette: Guidelines for using namespaces 193 | 194 | [bullet] 195 | Ray Johnson: Tcl/Tk style guide 196 | 197 | [bullet] 198 | Ray Johnson: Engineering manual 199 | 200 | [bullet] 201 | Andreas Kupries: Documentation doctools 202 | 203 | [bullet] 204 | Boris Beizer: Software Testing Techniques 205 | 206 | [bullet] 207 | ??: Managing project with make 208 | 209 | [bullet] 210 | ??: Information on stubs 211 | 212 | [bullet] 213 | Don Porter: Man page on tcltest 214 | 215 | [bullet] 216 | ??: Autoconf documentation 217 | 218 | [list_end] 219 | -------------------------------------------------------------------------------- /tea/writingtests.txt: -------------------------------------------------------------------------------- 1 | [section {Chapter 7. WRITING AND RUNNING TESTS}] 2 | 3 | As the developer of an extension you are probably in the best 4 | position to identify the kind of things that need to be tested: 5 | 6 | [list_begin bullet] 7 | 8 | [bullet] 9 | The reaction of a command to valid input 10 | 11 | [bullet] 12 | What constitutes invalid input and how your extension deals 13 | with that. 14 | 15 | [list_end] 16 | 17 | It is quite possible to give theoretically sound guidelines for 18 | a complete test suite (complete that is in the sense of some 19 | test criterium, for instance that all code is executed at 20 | least once when all the test cases are run). However, the 21 | same theory also teaches us that each criterium has its 22 | weaknesses and will let through certain types of bugs. 23 | Furthermore, the number of test cases and the management 24 | of the test code becomes unwieldy when your extension achieves 25 | a considerable size. (For more information, the classical 26 | book by Boris Beizer, Software Testing Techniques, can be consulted. 27 | There are many more similar publications.) 28 | 29 | [para] 30 | Let us deal instead with some more practical guidelines. Here are 31 | some minimal requirements: 32 | 33 | [list_begin bullet] 34 | 35 | [bullet] 36 | For all public commands in your extension, there should be at least 37 | one test case. If possible the test case should be small so that 38 | it concentrates on one and only one command, but that may not 39 | always be possible. 40 | 41 | [bullet] 42 | For all public commands at least one or two examples with [emph invalid] 43 | input (if there is any) should be defined. The purpose is to 44 | show that the extension can gracefully deal with such erroneous 45 | calls. 46 | [list_end] 47 | 48 | [para] 49 | If practical, then: 50 | 51 | [list_begin bullet] 52 | 53 | [bullet] 54 | You should define a fairly exhaustive set of 55 | test cases that together deal with all the defined functionality of the extension. 56 | 57 | [bullet] 58 | In a similar fashion all error cases should be included. 59 | 60 | [list_end] 61 | 62 | How we set up the tests? Simple, use the [emph tcltest] package. This package 63 | provides a complete and versatile infrastructure to deal with running 64 | tests and reporting the results (see the quite extensive manual page). 65 | 66 | [para] 67 | Here is a summary: 68 | 69 | [list_begin bullet] 70 | 71 | [bullet] 72 | Define small scripts that should return a known value. 73 | 74 | [bullet] 75 | The scripts are run and the actually returned value is compared 76 | to the expected value. 77 | 78 | [bullet] 79 | If there is a difference, then this is reported and the test fails. 80 | 81 | [bullet] 82 | For more flexibility: 83 | 84 | [list_begin bullet] 85 | [bullet] 86 | You can define the way the two values should be compared 87 | (via glob or regular expression matching or via a user-defined 88 | method, in case of floating-point values for instance) 89 | [bullet] 90 | You can define constraints for the tests - some tests only make 91 | sense on a specific platform for instance 92 | [bullet] 93 | You can prepare files via the special procedures that the tcltest 94 | package provides, so that they can be cleaned up properly. 95 | [list_end] 96 | 97 | [list_end] 98 | 99 | To illustrate this discussion with an example, consider an extension 100 | with a command "isValidXYZFile", this command checks the contents of the 101 | given file (the one argument to this command) and returns 1 if it is 102 | indeed a valid XYZ file (whatever XYZ files are) and 0 if it is not. 103 | 104 | [para] 105 | Test cases for this command could include: 106 | 107 | [list_begin bullet] 108 | 109 | [bullet] 110 | A valid XYZ file 111 | 112 | [bullet] 113 | An arbitrary file (that certainly is not an XYZ file) 114 | 115 | [bullet] 116 | No argument at all 117 | 118 | [bullet] 119 | A non-existent file 120 | 121 | [bullet] 122 | Two or more commands 123 | 124 | [list_end] 125 | 126 | The first two fall in the category "valid input", the others represent 127 | particular invalid input that the command is supposed to gracefully 128 | deal with (recognise that the input is not correct and report an 129 | error). 130 | 131 | [para] 132 | Traditionally, test scripts are contained in files with the extension 133 | ".test". So let us put the following code in a file "xyzfiles.test" to 134 | test our "xyzfiles" extension: 135 | [example { 136 | # 137 | # Initialise the test package (we need only the "test" command) 138 | # 139 | package require tcltest 140 | namespace import ::tcltest::test 141 | 142 | # 143 | # Get our xyzfiles extension 144 | # 145 | package require xyzfiles 146 | namespace import xyzfiles::isValidXYZFile 147 | 148 | # 149 | # Our tests for valid input (sample.xyz is a valid XYZ file 150 | # ships with the extension, sampe2.xyz is an invalid but 151 | # existing file) 152 | # 153 | 154 | test "xyzfiles-1.1" "Valid XYZ file" -body { 155 | isValidXYZFile "sample.xyz" 156 | } -result 1 ;# It is a valid file, so the command returns 1 157 | 158 | test "xyzfiles-1.2" "Not a valid XYZ file" -body { 159 | isValidXYZFile "sample2.xyz" 160 | } -result 0 161 | 162 | # 163 | # Invalid input (the major test number is changed for convenience 164 | # only): 165 | # 166 | 167 | test "xyzfiles-2.1" "No argument" -body { 168 | isValidXYZFile 169 | } -returnCodes error -result "wrong # args: *" -match glob 170 | 171 | # tcltest uses exact matching by default, so we change that for this case 172 | 173 | test "xyzfiles-2.2" "Non-existent file" -body { 174 | isValidXYZFile "non-existent-file.xyz" 175 | } -returnCodes error -result "Non existent file *" -match glob 176 | 177 | test "xyzfiles-2.3" "Too many arguments" -body { 178 | isValidXYZFile 1 2 3 4 179 | } -returnCodes error -result "wrong # args: *" -match glob 180 | }] 181 | 182 | Note that in the last three cases we use the [lb]catch[rb] command to catch 183 | the intended errors and we use the glob matching option to match against 184 | a rough string, rather than an exact string. 185 | 186 | [para] 187 | Testing the arguments is of course much more important in case 188 | of a compiled extension than in case of a Tcl-only procedure, but 189 | if there are subcommands that require different numbers of arguments 190 | it can be a good idea to add tests like the above. 191 | 192 | [para] 193 | These tests can be run by the command: 194 | [example { 195 | > make test 196 | }] 197 | (See the code for "test" target in the make file) 198 | 199 | [para] 200 | It is good style to always run every test in a test suite. If some 201 | tests fail on some platforms, use test constraints to prevent running 202 | of those particular tests. You can also use test constraints to 203 | protect non-test pieces of code in the test file. 204 | -------------------------------------------------------------------------------- /teapot.txt.in: -------------------------------------------------------------------------------- 1 | Package @PACKAGE_NAME@ @PACKAGE_VERSION@ 2 | Meta platform @PLATFORM@ 3 | Meta require {Tcl @TCL_VERSION@} 4 | Meta require {TclOO 1} 5 | Meta entrykeep . 6 | Meta excluded *.a *.tap *.lib 7 | Meta included @PKG_LIB_FILE@ *.tcl 8 | 9 | Meta as::author {Christian Gollwitzer} 10 | Meta as::origin http://auriocus.github.io/VecTcl/ 11 | Meta category Math and Numerics 12 | 13 | Meta description A numeric array extension for Tcl with support for vectors, 14 | Meta description matrices and higher-rank tensors of integers, floating point 15 | Meta description and complex numbers. VecTcl has builtin support for array 16 | Meta description shaping, slicing and common linear algebra subroutines. 17 | Meta description Arrays are represented as nested lists with an optimized 18 | Meta description internal data storage. Therefore, seamless integration with 19 | Meta description Tcl and other packages like math::linearalgebra is ensured 20 | Meta description while good performance is provided. The user interface 21 | Meta description consists of a single command, vexpr, which acts as an 22 | Meta description expression evaluator similar to expr. The language supported 23 | Meta description by vexpr is closely modelled after commercial linear algebra 24 | Meta description packages and the syntax used by textbooks. 25 | 26 | Meta license BSD 27 | Meta subject math numeric vector matrix complex {linear algebra} 28 | Meta summary Vector and matrix math 29 | -------------------------------------------------------------------------------- /tests/all.tcl: -------------------------------------------------------------------------------- 1 | # all.tcl -- 2 | # 3 | # This file contains a top-level script to run all of the Tcl 4 | # tests. Execute it by invoking "source all.test" when running tcltest 5 | # in this directory. 6 | # 7 | # Copyright (c) 1998-2000 by Scriptics Corporation. 8 | # All rights reserved. 9 | 10 | if {[lsearch [namespace children] ::tcltest] == -1} { 11 | package require tcltest 12 | namespace import ::tcltest::* 13 | } 14 | 15 | set ::tcltest::testSingleFile false 16 | set ::tcltest::testsDirectory [file dir [info script]] 17 | 18 | # We need to ensure that the testsDirectory is absolute 19 | if {[catch {::tcltest::normalizePath ::tcltest::testsDirectory}]} { 20 | # The version of tcltest we have here does not support 21 | # 'normalizePath', so we have to do this on our own. 22 | 23 | set oldpwd [pwd] 24 | catch {cd $::tcltest::testsDirectory} 25 | set ::tcltest::testsDirectory [pwd] 26 | cd $oldpwd 27 | } 28 | 29 | set chan $::tcltest::outputChannel 30 | 31 | puts $chan "Tests running in interp: [info nameofexecutable]" 32 | puts $chan "Tests running with pwd: [pwd]" 33 | puts $chan "Tests running in working dir: $::tcltest::testsDirectory" 34 | if {[llength $::tcltest::skip] > 0} { 35 | puts $chan "Skipping tests that match: $::tcltest::skip" 36 | } 37 | if {[llength $::tcltest::match] > 0} { 38 | puts $chan "Only running tests that match: $::tcltest::match" 39 | } 40 | 41 | if {[llength $::tcltest::skipFiles] > 0} { 42 | puts $chan "Skipping test files that match: $::tcltest::skipFiles" 43 | } 44 | if {[llength $::tcltest::matchFiles] > 0} { 45 | puts $chan "Only sourcing test files that match: $::tcltest::matchFiles" 46 | } 47 | 48 | set timeCmd {clock format [clock seconds]} 49 | puts $chan "Tests began at [eval $timeCmd]" 50 | 51 | # load the package 52 | 53 | 54 | set dir [file dirname [file dirname [file normalize [info script]]]] 55 | set auto_path [linsert $auto_path 0 $dir [file join $dir lib]] 56 | puts [join $auto_path \n] 57 | package require vectcl 58 | namespace import vectcl::vexpr 59 | 60 | #trace add execution tcltest::test enter printargs 61 | proc printargs {args} { puts $args } 62 | 63 | #source tests/concat.test 64 | #source tests/reduction.test 65 | #source tests/concat.test 66 | #source tests/reduction.test 67 | 68 | # source each of the specified tests 69 | foreach file [lsort [::tcltest::getMatchingFiles]] { 70 | set tail [file tail $file] 71 | puts $chan $tail 72 | if {[catch {source $file} msg]} { 73 | puts $chan $msg 74 | } 75 | } 76 | 77 | # cleanup 78 | puts $chan "\nTests ended at [eval $timeCmd]" 79 | ::tcltest::cleanupTests 1 80 | return 81 | 82 | -------------------------------------------------------------------------------- /tests/compiler.test: -------------------------------------------------------------------------------- 1 | test compiler literal-1 -body { 2 | 3 | vexpr {{1 2 3 4}} 4 | 5 | } -result {1 2 3 4} 6 | 7 | test compiler literal-2 -body { 8 | 9 | vexpr {{{1 2} {3 4}}} 10 | 11 | } -result {{1 2} {3 4}} 12 | 13 | test compiler sliceexpression-1 -body { 14 | 15 | set x {1 2 3 4 5 6 7} 16 | vexpr {n=2; m=3; x[n:m]} 17 | 18 | } -result {3 4} 19 | 20 | test compiler sliceexpression-2 -body { 21 | 22 | set x {1 2 3 4 5 6 7} 23 | vexpr {n=2; m=3; x[n:m*n]} 24 | 25 | } -result {3 4 5 6 7} 26 | 27 | test compiler sliceexpression-3 -body { 28 | 29 | set x {1 2 3 4 5 6 7} 30 | vexpr {n=2; m=3; x[n:m+n]} 31 | 32 | } -result {3 4 5 6} 33 | 34 | test compiler sliceexpression-4 -body { 35 | 36 | set x {1 2 3 4 5 6 7} 37 | vexpr {n=2; m=3; x[n:m*2]} 38 | 39 | } -result {3 4 5 6 7} 40 | 41 | test compiler sliceexpression-5 -body { 42 | 43 | set x {1 2 3 4 5 6 7} 44 | vexpr {n=2; m=3; x[n:m*3]} 45 | 46 | } -result {Stop index out of bounds} -returnCodes 1 47 | 48 | test compiler sliceexpression-6 -body { 49 | 50 | set x {1 2 3 4 5 6 7} 51 | vexpr {end=-1; x[2:end]} 52 | 53 | } -result {3 4 5 6 7} 54 | 55 | test compiler sliceexpression-7 -body { 56 | 57 | set x {1 2 3 4 5 6 7} 58 | vexpr {end=-1; x[2:end-2]} 59 | 60 | } -result {3 4 5} 61 | 62 | test compiler sliceexpression-8 -body { 63 | 64 | set x {1 2 3 4 5 6 7} 65 | vexpr {end=-1; s=2; x[0:end-1:s]} 66 | 67 | } -result {1 3 5} 68 | 69 | test compiler sliceexpression-9 -body { 70 | 71 | set x {1 2 3 4 5 6 7} 72 | vexpr {end=-1; s=2; x[0:end-1:s*2]} 73 | 74 | } -result {1 5} 75 | 76 | test compiler boolif-1 -body { 77 | 78 | vexpr {r={ }; for x=1:20 { if x>5 && x<15 { r=vstack(r,x) }}; r} 79 | 80 | } -result {6 7 8 9 10 11 12 13 14} 81 | 82 | test compiler boolif-2 -body { 83 | 84 | vexpr {r={ }; for x=1:20 { if x>3 && x<5 || x>17 { r=vstack(r,x) }}; r} 85 | 86 | } -result {4 18 19 20} 87 | 88 | test compiler boolif-3 -body { 89 | 90 | vexpr {r={ }; for x=1:20 { if x>=3 && (x<=5 || x>=17) { r=vstack(r,x) }}; r} 91 | 92 | } -result {3 4 5 17 18 19 20} 93 | 94 | test compiler boolif-4 -body { 95 | 96 | vexpr {r={ }; for x=1:20 { if x>=3 { r=vstack(r,x) }}; r} 97 | 98 | } -result {3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20} 99 | 100 | test compiler boolif-5 -body { 101 | 102 | vexpr {r={ }; for x=1:20 { if !(x>=3) { r=vstack(r,x) }}; r} 103 | 104 | } -result {1 2} 105 | 106 | test compiler namespace-1 -body { 107 | 108 | set ::A {1 2 3} 109 | vexpr ::A 110 | 111 | } -result {1 2 3} 112 | 113 | 114 | test compiler namespace-2 -body { 115 | 116 | namespace eval a { 117 | namespace eval b { variable f 7 } 118 | proc t {} { vexpr b::f } 119 | } 120 | 121 | a::t 122 | 123 | } -result 7 124 | 125 | test compiler whitespace-1 -body { 126 | 127 | set a 2 128 | set b 3 129 | vexpr {min(a,b)} 130 | 131 | } -result 2 132 | 133 | test compiler whitespace-2 -body { 134 | 135 | set a 2 136 | set b 3 137 | vexpr { min(a,b)} 138 | 139 | } -result 2 140 | 141 | test compiler whitespace-3 -body { 142 | 143 | set a 2 144 | set b 3 145 | vexpr { min(a,b) } 146 | 147 | } -result 2 148 | 149 | test compiler whitespace-4 -body { 150 | 151 | set a 2 152 | set b 3 153 | vexpr { min(a,b ) } 154 | 155 | } -result 2 156 | 157 | test compiler whitespace-5 -body { 158 | 159 | set a 2 160 | set b 3 161 | vexpr { min( a,b ) } 162 | 163 | } -result 2 164 | 165 | test compiler whitespace-6 -body { 166 | 167 | set a 2 168 | set b 3 169 | vexpr { min( a ,b ) } 170 | 171 | } -result 2 172 | 173 | test compiler whitespace-7 -body { 174 | 175 | set a 2 176 | set b 3 177 | vexpr { min( a , b ) } 178 | 179 | } -result 2 180 | 181 | test compiler whitespace-8 -body { 182 | 183 | proc fun {} {} 184 | vexpr {fun()} 185 | 186 | } -result {} 187 | 188 | test compiler whitespace-9 -body { 189 | 190 | proc fun {} {} 191 | vexpr { fun()} 192 | 193 | } -result {} 194 | 195 | test compiler whitespace-10 -body { 196 | 197 | proc fun {} {} 198 | vexpr { fun() } 199 | 200 | } -result {} 201 | 202 | test compiler whitespace-13 -body { 203 | 204 | proc fun {} {} 205 | vexpr {fun( )} 206 | 207 | } -result {Error: Parse error in line 1:6 208 | fun( ) 209 | ^} -returnCodes 1 210 | 211 | test compiler whitespace-14 -body { 212 | 213 | proc fun {} {} 214 | vexpr {fun ()} 215 | 216 | } -result {Error: Parse error in line 1:4 217 | fun () 218 | ^} -returnCodes 1 219 | 220 | test compiler precedence-1 -body { 221 | 222 | vexpr {0 && 1 || 1} 223 | 224 | } -result 1 225 | 226 | test compiler precedence-2 -body { 227 | 228 | vexpr {0 && (1 || 1)} 229 | 230 | } -result 0 231 | 232 | test compiler precedence-3 -body { 233 | 234 | vexpr {1 || 1 && 0} 235 | 236 | } -result 1 237 | 238 | test compiler precedence-4 -body { 239 | 240 | vexpr {(1 || 1) && 0} 241 | 242 | } -result 0 243 | 244 | -------------------------------------------------------------------------------- /tests/concat.test: -------------------------------------------------------------------------------- 1 | 2 | if {[lsearch [namespace children] ::tcltest] == -1} { 3 | package require tcltest 4 | namespace import ::tcltest::* 5 | } 6 | 7 | 8 | test numarray concat1 -body { 9 | numarray concat {1.0 2.0} {1.0 1.0} 0 10 | } -result {1.0 2.0 1.0 1.0} 11 | 12 | test numarray concat2 -body { 13 | numarray concat {1.0 2.0} {1.0 1.0} 1 14 | } -result {{1.0 1.0} {2.0 1.0}} 15 | 16 | test numarray concat3 -body { 17 | numarray concat {1.0 2.0} {1.0 1.0} 2 18 | } -returnCodes error -result {Dimension out of bounds} 19 | 20 | test numarray concat4 -body { 21 | numarray concat {1.0 2.0} 1.0 0 22 | } -result {1.0 2.0 1.0} 23 | 24 | test numarray concat5 -body { 25 | numarray concat {1.0 2.0} 1.0 1 26 | } -result {{1.0 1.0} {2.0 1.0}} 27 | 28 | test numarray concat6 -body { 29 | numarray concat {1.0 2.0} 1.0 2 30 | } -returnCodes error -result {Dimension out of bounds} 31 | 32 | test numarray concat7 -body { 33 | numarray concat 5.0 {1.0 2.0} 0 34 | } -result {5.0 1.0 2.0} 35 | 36 | test numarray concat8 -body { 37 | numarray concat {1.0 2.0} 5.0 1 38 | } -result {{1.0 5.0} {2.0 5.0}} 39 | 40 | test numarray concat9 -body { 41 | numarray concat {1.0 2.0} {3.0 4.0} 1 42 | } -result {{1.0 3.0} {2.0 4.0}} 43 | 44 | test numarray concat10 -body { 45 | numarray concat {{1.0 2.0} {3.0 4.0}} 5.0 0 46 | } -result {{1.0 2.0} {3.0 4.0} {5.0 5.0}} 47 | 48 | test numarray concat11 -body { 49 | numarray concat {{1.0 2.0} {3.0 4.0}} 5.0 1 50 | } -result {{1.0 2.0 5.0} {3.0 4.0 5.0}} 51 | 52 | test numarray concat12 -body { 53 | numarray concat {{1.0 2.0} {3.0 4.0}} {{5.0 6.0}} 0 54 | } -result {{1.0 2.0} {3.0 4.0} {5.0 6.0}} 55 | 56 | test numarray concat12 -body { 57 | numarray concat {{1.0 2.0} {3.0 4.0}} {{5.0 6.0}} 1 58 | } -returnCodes error -result {Dimension mismatch} 59 | 60 | 61 | 62 | 63 | # cleanup 64 | # cleanup 65 | ::tcltest::cleanupTests 66 | return 67 | 68 | -------------------------------------------------------------------------------- /tests/iterator.test: -------------------------------------------------------------------------------- 1 | namespace import vectcl::vexpr 2 | 3 | test aiterator stripdimensions-1 -body { 4 | 5 | set x {{1 2 3 4}} 6 | set y {5 6 7 8} 7 | vexpr {y=reshape(y,4,1)} 8 | vexpr {x+=y} 9 | 10 | } -result {{6 8 10 12}} 11 | 12 | test aiterator stripdimensions-2 -body { 13 | 14 | set x {1 2 3 4} 15 | vexpr {y=reshape({5 6 7 8}, 4, 1) 16 | x+=y } 17 | 18 | } -result {6 8 10 12} 19 | 20 | test aiterator stripdimensions-3 -body { 21 | 22 | set x {{1 2 3 4}} 23 | vexpr {y=reshape({5 6 7 8}, 4, 1) 24 | x+=y } 25 | 26 | } -result {{6 8 10 12}} 27 | 28 | 29 | -------------------------------------------------------------------------------- /tests/linalg.test: -------------------------------------------------------------------------------- 1 | # Commands covered: numarray 2 | # 3 | # This file contains a collection of tests for one or more of the Tcl 4 | # built-in commands. Sourcing this file into Tcl runs the tests and 5 | # generates output for errors. No output means no errors were found. 6 | # 7 | # Copyright (c) 2000 by Scriptics Corporation. 8 | # 9 | # See the file "license.terms" for information on usage and redistribution 10 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 | 12 | if {[lsearch [namespace children] ::tcltest] == -1} { 13 | package require tcltest 14 | namespace import ::tcltest::* 15 | } 16 | 17 | lappend auto_path [file dirname [file dirname [info script]]] 18 | package require vectcl 19 | 20 | proc matrix {args} { 21 | # create matrix with dimensions as given in args 22 | set d 1 23 | foreach n $args { set d [expr {$d*$n}] } 24 | set l {} 25 | for {set i 1} {$i<=$d} {incr i} { lappend l [expr {double($i)}] } 26 | numarray reshape $l {*}$args 27 | } 28 | 29 | test linalg kroneckerdot -body { 30 | numarray * {1.0 2.0 3.0} {{1.0 2.0}} 31 | } -result {{1.0 2.0} {2.0 4.0} {3.0 6.0}} 32 | 33 | test linalg scalardot-1 -body { 34 | numarray * {1.0 2.0 3.0} 2.0 35 | } -result {2.0 4.0 6.0} 36 | 37 | test linalg scalardot-2 -body { 38 | numarray * 2.0 {1.0 2.0 3.0} 39 | } -result {2.0 4.0 6.0} 40 | 41 | test linalg dot-1 -body { 42 | numarray * {{1.0 2.0} {3.0 4.0}} {{1.0 0.0} {1.0 0.0}} 43 | } -result {{3.0 0.0} {7.0 0.0}} 44 | 45 | test linalg dot-2 -body { 46 | numarray * {{1.0 2.0} {3.0 4.0}} {1.0 1.0} 47 | } -result {3.0 7.0} 48 | 49 | test linalg dot-3 -body { 50 | numarray * {{1.0 2.0 3.0 4.0}} {1.0 2.0 3.0 4.0} 51 | } -result {30.0} 52 | 53 | test linalg dot-4 -body { 54 | numarray * {1.0 2.0} {1.0 1.0} 55 | } -returnCodes error -result {incompatible operands} 56 | 57 | test linalg dot-5 -body { 58 | 59 | vexpr {matrix(2,2,3)*matrix(3,2)} 60 | 61 | } -result {{{22.0 28.0} {49.0 64.0}} {{76.0 100.0} {103.0 136.0}}} 62 | 63 | test linalg dot-6 -body { 64 | 65 | vexpr {matrix(2,5)*matrix(5,3)} 66 | 67 | } -result {{135.0 150.0 165.0} {310.0 350.0 390.0}} 68 | 69 | test linalg dot-7 -body { 70 | 71 | vexpr {matrix(2,3)*matrix(3,3)} 72 | 73 | } -result {{30.0 36.0 42.0} {66.0 81.0 96.0}} 74 | 75 | test linalg dot-8 -body { 76 | 77 | vexpr { 78 | A=matrix(2,5) 79 | B=matrix(5,3) 80 | A[:,2:4]*B[1:3,:] 81 | } 82 | 83 | } -result {{90.0 102.0 114.0} {195.0 222.0 249.0}} 84 | 85 | -------------------------------------------------------------------------------- /tests/nrcache: -------------------------------------------------------------------------------- 1 | sum 8 concat 22 refcount 2 dimensions 3 slice 13 slicetranspose 2 get 7 scalardot 2 dot 8 min 10 max 6 std 3 mean 2 binop 7 assignop 10 assignslice 4 unaryminus 5 complex 20 reduction 6 2d 1 stripdimensions 3 literal 2 shape 6 dblconv 2 sliceexpression 9 boolif 5 boolean 13 shimmering 2 namespace 2 whitespace 14 precedence 4 fixed 34 int 2 bool 5 -------------------------------------------------------------------------------- /tests/reduction.test: -------------------------------------------------------------------------------- 1 | # Commands covered: numarray 2 | # 3 | # This file contains a collection of tests for one or more of the Tcl 4 | # built-in commands. Sourcing this file into Tcl runs the tests and 5 | # generates output for errors. No output means no errors were found. 6 | # 7 | # Copyright (c) 2000 by Scriptics Corporation. 8 | # 9 | # See the file "license.terms" for information on usage and redistribution 10 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 | 12 | if {[lsearch [namespace children] ::tcltest] == -1} { 13 | package require tcltest 14 | namespace import ::tcltest::* 15 | } 16 | 17 | test reduction sum-1 -body { 18 | 19 | set A {{1.0 2.0} {3.0 4.0}} 20 | vexpr {sum(A)} 21 | 22 | } -result {4.0 6.0} 23 | 24 | test reduction sum-2 -body { 25 | 26 | set A {{1.0 2.0} {3.0 4.0}} 27 | vexpr {sum(A,1)} 28 | 29 | } -result {3.0 7.0} 30 | 31 | 32 | test reduction min-1 -body { 33 | 34 | set A {{1.0 2.0} {3.0 4.0}} 35 | vexpr {min(A)} 36 | 37 | } -result {1.0 2.0} 38 | 39 | test reduction min-2 -body { 40 | 41 | set A {{1.0 2.0} {3.0 4.0}} 42 | vexpr {min(A,2.0)} 43 | 44 | } -result {{1.0 2.0} {2.0 2.0}} 45 | 46 | test reduction min-3 -body { 47 | 48 | set A {{1.0 2.0} {3.0 4.0}} 49 | vexpr {min(A,5.0)} 50 | 51 | } -result {{1.0 2.0} {3.0 4.0}} 52 | 53 | test reduction min-4 -body { 54 | 55 | set A {{1.0 2.0} {3.0 4.0}} 56 | vexpr {min(3.0,A)} 57 | 58 | } -result {{1.0 2.0} {3.0 3.0}} 59 | 60 | test reduction min-5 -body { 61 | 62 | set A {{1.0 2.0} {3.0 4.0}} 63 | vexpr {axismin(A,-1)} 64 | 65 | } -result {Dimension mismatch} -returnCodes 1 66 | 67 | test reduction min-6 -body { 68 | 69 | set A {{1.0 2.0} {3.0 4.0}} 70 | vexpr {axismin(A,0)} 71 | 72 | } -result {1.0 2.0} 73 | 74 | test reduction min-7 -body { 75 | 76 | set A {{1.0 2.0} {3.0 4.0}} 77 | vexpr {axismin(A,1)} 78 | 79 | } -result {1.0 3.0} 80 | 81 | test reduction min-8 -body { 82 | 83 | set A {{1.0 2.0} {3.0 4.0}} 84 | vexpr {axismin(A,2)} 85 | 86 | } -result {Dimension mismatch} -returnCodes 1 87 | 88 | test reduction min-9 -body { 89 | 90 | set A {{1.0 2.0} {3.0 4.0}} 91 | set B {{0.0 3.0} {1.0 2.0}} 92 | vexpr {min(A,B)} 93 | 94 | } -result {{0.0 2.0} {1.0 2.0}} 95 | 96 | test reduction min-10 -body { 97 | 98 | set A {{1.0 2.0} {3.0 4.0}} 99 | set B {{0.0 3.0}} 100 | vexpr {min(A,B)} 101 | 102 | } -result {incompatible operands} -returnCodes 1 103 | 104 | test reduction max-1 -body { 105 | 106 | set A {{1.0 2.0} {3.0 4.0}} 107 | vexpr {max(A)} 108 | 109 | } -result {3.0 4.0} 110 | 111 | test reduction max-2 -body { 112 | 113 | set A {{1.0 2.0} {3.0 4.0}} 114 | vexpr {max(A,2.0)} 115 | 116 | } -result {{2.0 2.0} {3.0 4.0}} 117 | 118 | test reduction max-3 -body { 119 | 120 | set A {{1.0 2.0} {3.0 4.0}} 121 | vexpr {max(A,5.0)} 122 | 123 | } -result {{5.0 5.0} {5.0 5.0}} 124 | 125 | test reduction max-4 -body { 126 | 127 | set A {{1.0 2.0} {3.0 4.0}} 128 | vexpr {axismax(A,0)} 129 | 130 | } -result {3.0 4.0} 131 | 132 | test reduction max-5 -body { 133 | 134 | set A {{1.0 2.0} {3.0 4.0}} 135 | vexpr {axismax(A,1)} 136 | 137 | } -result {2.0 4.0} 138 | 139 | test reduction max-6 -body { 140 | 141 | set A {{1.0 2.0} {3.0 4.0}} 142 | vexpr {axismax(A,2)} 143 | 144 | } -result {Dimension mismatch} -returnCodes 1 145 | 146 | test reduction sum-3 -body { 147 | 148 | vexpr {sum({1.0 2.0 3.0 4.0})} 149 | 150 | } -result 10.0 151 | 152 | test reduction sum-4 -body { 153 | 154 | set x {} 155 | vexpr sum(x) 156 | 157 | } -result {Empty array} -returnCodes 1 158 | 159 | test reduction sum-5 -body { 160 | 161 | set A {{{1.0 2.0} {3.0 4.0}} {{5.0 6.0} {7.0 8.0}} {{9.0 10.0} {11.0 12.0}}} 162 | vexpr {sum(A)} 163 | 164 | } -result {{15.0 18.0} {21.0 24.0}} 165 | 166 | test reduction sum-6 -body { 167 | 168 | set A {{{1.0 2.0} {3.0 4.0}} {{5.0 6.0} {7.0 8.0}} {{9.0 10.0} {11.0 12.0}}} 169 | vexpr {sum(A,1)} 170 | 171 | } -result {{4.0 6.0} {12.0 14.0} {20.0 22.0}} 172 | 173 | test reduction sum-7 -body { 174 | 175 | set A {{{1.0 2.0} {3.0 4.0}} {{5.0 6.0} {7.0 8.0}} {{9.0 10.0} {11.0 12.0}}} 176 | vexpr {sum(A,2)} 177 | 178 | } -result {{3.0 7.0} {11.0 15.0} {19.0 23.0}} 179 | 180 | test reduction sum-8 -body { 181 | 182 | set A {{{1.0 2.0} {3.0 4.0}} {{5.0 6.0} {7.0 8.0}} {{9.0 10.0} {11.0 12.0}}} 183 | vexpr {sum(A,3)} 184 | 185 | } -result {Dimension mismatch} -returnCodes 1 186 | 187 | test reduction std-1 -body { 188 | 189 | vexpr { std({1.0 2.0 3.0}) } 190 | 191 | } -result 1.0 192 | 193 | 194 | test reduction std-2 -body { 195 | 196 | set l {} 197 | vexpr { std(l) } 198 | 199 | } -result {Empty array} -returnCodes 1 200 | 201 | test reduction std-3 -body { 202 | 203 | set l {1.0 0.0} 204 | vexpr { std1(l) } 205 | 206 | } -result 0.5 207 | 208 | test reduction mean-1 -body { 209 | 210 | set l {5.0} 211 | vexpr { mean(l) } 212 | 213 | } -result 5.0 214 | 215 | test reduction mean-2 -body { 216 | 217 | set l {0.0 2.0 7.0} 218 | vexpr { mean(l) } 219 | 220 | } -result 3.0 221 | 222 | -------------------------------------------------------------------------------- /tools/expand.tcl: -------------------------------------------------------------------------------- 1 | # create the parser from the grammar using pt 2 | # if it was changed. 3 | 4 | set toolpath [file dirname [info script]] 5 | 6 | package require textutil::expander 7 | package require fileutil 8 | 9 | if {[llength $argv]!=2} { 10 | puts stderr "Usage: $argv0 input.tcl.c output.c" 11 | exit -1 12 | } 13 | 14 | lassign $argv templatefn resultfn 15 | 16 | set template [fileutil::cat $templatefn] 17 | set templatepath [file dirname $templatefn] 18 | 19 | set expander [textutil::expander %AUTO%] 20 | $expander setbrackets "\${" "\$}" 21 | 22 | proc C {text} { 23 | $::expander cappend [$::expander expand $text] 24 | return "" 25 | } 26 | 27 | source [file join $templatepath defs.tcl] 28 | 29 | fileutil::writeFile $resultfn [$expander expand $template] 30 | -------------------------------------------------------------------------------- /tools/parsergen.tcl: -------------------------------------------------------------------------------- 1 | # create the parser from the grammar using pt 2 | # if it was changed. 3 | package require pt::pgen 4 | 5 | if {[llength $argv]!=2} { 6 | puts stderr "Usage: $argv0 " 7 | exit -1 8 | } 9 | 10 | lassign $argv grammarfn parserfn 11 | 12 | set fd [open $grammarfn r] 13 | set grammar [read $fd] 14 | close $fd 15 | 16 | set parser [pt::pgen peg $grammar c -main StartSymbol] 17 | 18 | set fd [open $parserfn w] 19 | puts $fd $parser 20 | close $fd 21 | 22 | -------------------------------------------------------------------------------- /vectclConfig.sh.in: -------------------------------------------------------------------------------- 1 | # vectclConfig.sh -- 2 | # 3 | # This shell script (for sh) is generated automatically by VecTcl's 4 | # configure script. It will create shell variables for most of 5 | # the configuration options discovered by the configure script. 6 | # This script is intended to be included by the configure scripts 7 | # for VecTcl extensions so that they don't have to figure this all 8 | # out for themselves. This file does not duplicate information 9 | # already provided by tclConfig.sh, so you may need to use that 10 | # file in addition to this one. 11 | # 12 | # The information in this file is specific to a single platform. 13 | 14 | # VecTcl's version number. 15 | vectcl_VERSION='@PACKAGE_VERSION@' 16 | VECTCL_VERSION='@PACKAGE_VERSION@' 17 | 18 | # The name of the VecTcl library (may be either a .a file or a shared library): 19 | vectcl_LIB_FILE=@vectcl_LIB_FILE@ 20 | VECTCL_LIB_FILE=@vectcl_LIB_FILE@ 21 | 22 | # String to pass to linker to pick up the VecTcl library from its 23 | # build directory. 24 | vectcl_BUILD_LIB_SPEC='@vectcl_BUILD_LIB_SPEC@' 25 | VECTCL_BUILD_LIB_SPEC='@vectcl_BUILD_LIB_SPEC@' 26 | 27 | # String to pass to linker to pick up the VecTcl library from its 28 | # installed directory. 29 | vectcl_LIB_SPEC='@vectcl_LIB_SPEC@' 30 | VECTCL_LIB_SPEC='@vectcl_LIB_SPEC@' 31 | 32 | # The name of the VecTcl stub library (a .a file): 33 | vectcl_STUB_LIB_FILE=@vectcl_STUB_LIB_FILE@ 34 | VECTCL_STUB_LIB_FILE=@vectcl_STUB_LIB_FILE@ 35 | 36 | # String to pass to linker to pick up the VecTcl stub library from its 37 | # build directory. 38 | vectcl_BUILD_STUB_LIB_SPEC='@vectcl_BUILD_STUB_LIB_SPEC@' 39 | VECTCL_BUILD_STUB_LIB_SPEC='@vectcl_BUILD_STUB_LIB_SPEC@' 40 | 41 | # String to pass to linker to pick up the VecTcl stub library from its 42 | # installed directory. 43 | vectcl_STUB_LIB_SPEC='@vectcl_STUB_LIB_SPEC@' 44 | VECTCL_STUB_LIB_SPEC='@vectcl_STUB_LIB_SPEC@' 45 | 46 | # String to pass to linker to pick up the VecTcl stub library from its 47 | # build directory. 48 | vectcl_BUILD_STUB_LIB_PATH='@vectcl_BUILD_STUB_LIB_PATH@' 49 | VECTCL_BUILD_STUB_LIB_PATH='@vectcl_BUILD_STUB_LIB_PATH@' 50 | 51 | # String to pass to linker to pick up the VecTcl stub library from its 52 | # installed directory. 53 | vectcl_STUB_LIB_PATH='@vectcl_STUB_LIB_PATH@' 54 | VECTCL_STUB_LIB_PATH='@vectcl_STUB_LIB_PATH@' 55 | 56 | # String to pass to the compiler so that an extension can 57 | # find installed VecTcl headers. 58 | vectcl_INCLUDE_SPEC='@vectcl_INCLUDE_SPEC@' 59 | VECTCL_INCLUDE_SPEC='@vectcl_INCLUDE_SPEC@' 60 | -------------------------------------------------------------------------------- /win/sample.rc: -------------------------------------------------------------------------------- 1 | // sample.rc - Copyright (C) 2006 Pat Thoyts 2 | // 3 | // There is no need to modify this file. 4 | // 5 | 6 | #include 7 | 8 | VS_VERSION_INFO VERSIONINFO 9 | FILEVERSION COMMAVERSION 10 | PRODUCTVERSION COMMAVERSION 11 | FILEFLAGSMASK 0x3fL 12 | #ifdef DEBUG 13 | FILEFLAGS VS_FF_DEBUG 14 | #else 15 | FILEFLAGS 0x0L 16 | #endif 17 | FILEOS VOS__WINDOWS32 18 | FILETYPE VFT_DLL 19 | FILESUBTYPE 0x0L 20 | BEGIN 21 | BLOCK "StringFileInfo" 22 | BEGIN 23 | BLOCK "040904b0" 24 | BEGIN 25 | VALUE "FileDescription", "Tcl Sample Extension " DOTVERSION "\0" 26 | VALUE "OriginalFilename", "sample" VERSION ".dll\0" 27 | VALUE "CompanyName", "The Tcl Development Community\0" 28 | VALUE "FileVersion", DOTVERSION "\0" 29 | VALUE "LegalCopyright", "Copyright \251 1999 Scriptics Corp.\0" 30 | VALUE "ProductName", "Tcl Sample Extension " DOTVERSION "\0" 31 | VALUE "ProductVersion", DOTVERSION "\0" 32 | END 33 | END 34 | BLOCK "VarFileInfo" 35 | BEGIN 36 | VALUE "Translation", 0x409, 1200 37 | END 38 | END 39 | --------------------------------------------------------------------------------