--- /dev/null
+USING: alien alien.c-types alien.syntax kernel system combinators ;
+IN: math.blas.cblas
+
+<< "cblas" {
+ { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
+ { [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
+ { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] }
+ { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library ] }
+ [ "libblas.so" "cdecl" add-library ]
+} cond >>
+
+LIBRARY: cblas
+
+TYPEDEF: int CBLAS_ORDER
+: CblasRowMajor 101 ; inline
+: CblasColMajor 102 ; inline
+
+TYPEDEF: int CBLAS_TRANSPOSE
+: CblasNoTrans 111 ; inline
+: CblasTrans 112 ; inline
+: CblasConjTrans 113 ; inline
+
+TYPEDEF: int CBLAS_UPLO
+: CblasUpper 121 ; inline
+: CblasLower 122 ; inline
+
+TYPEDEF: int CBLAS_DIAG
+: CblasNonUnit 131 ; inline
+: CblasUnit 132 ; inline
+
+TYPEDEF: int CBLAS_SIDE
+: CblasLeft 141 ; inline
+: CblasRight 142 ; inline
+
+TYPEDEF: int CBLAS_INDEX
+
+C-STRUCT: CBLAS_C
+ { "float" "real" }
+ { "float" "imag" } ;
+C-STRUCT: CBLAS_Z
+ { "double" "real" }
+ { "double" "imag" } ;
+
+! Level 1 BLAS (scalar-vector and vector-vector)
+
+FUNCTION: float cblas_sdsdot
+ ( int N, float alpha, float* X, int incX, float* Y, int incY ) ;
+FUNCTION: double cblas_dsdot
+ ( int N, float* X, int incX, float* Y, int incY ) ;
+FUNCTION: float cblas_sdot
+ ( int N, float* X, int incX, float* Y, int incY ) ;
+FUNCTION: double cblas_ddot
+ ( int N, double* X, int incX, double* Y, int incY ) ;
+
+FUNCTION: void cblas_cdotu_sub
+ ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotu ) ;
+FUNCTION: void cblas_cdotc_sub
+ ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotc ) ;
+
+FUNCTION: void cblas_zdotu_sub
+ ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotu ) ;
+FUNCTION: void cblas_zdotc_sub
+ ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotc ) ;
+
+FUNCTION: float cblas_snrm2
+ ( int N, float* X, int incX ) ;
+FUNCTION: float cblas_sasum
+ ( int N, float* X, int incX ) ;
+
+FUNCTION: double cblas_dnrm2
+ ( int N, double* X, int incX ) ;
+FUNCTION: double cblas_dasum
+ ( int N, double* X, int incX ) ;
+
+FUNCTION: float cblas_scnrm2
+ ( int N, CBLAS_C* X, int incX ) ;
+FUNCTION: float cblas_scasum
+ ( int N, CBLAS_C* X, int incX ) ;
+
+FUNCTION: double cblas_dznrm2
+ ( int N, CBLAS_Z* X, int incX ) ;
+FUNCTION: double cblas_dzasum
+ ( int N, CBLAS_Z* X, int incX ) ;
+
+FUNCTION: CBLAS_INDEX cblas_isamax
+ ( int N, float* X, int incX ) ;
+FUNCTION: CBLAS_INDEX cblas_idamax
+ ( int N, double* X, int incX ) ;
+FUNCTION: CBLAS_INDEX cblas_icamax
+ ( int N, CBLAS_C* X, int incX ) ;
+FUNCTION: CBLAS_INDEX cblas_izamax
+ ( int N, CBLAS_Z* X, int incX ) ;
+
+FUNCTION: void cblas_sswap
+ ( int N, float* X, int incX, float* Y, int incY ) ;
+FUNCTION: void cblas_scopy
+ ( int N, float* X, int incX, float* Y, int incY ) ;
+FUNCTION: void cblas_saxpy
+ ( int N, float alpha, float* X, int incX, float* Y, int incY ) ;
+
+FUNCTION: void cblas_dswap
+ ( int N, double* X, int incX, double* Y, int incY ) ;
+FUNCTION: void cblas_dcopy
+ ( int N, double* X, int incX, double* Y, int incY ) ;
+FUNCTION: void cblas_daxpy
+ ( int N, double alpha, double* X, int incX, double* Y, int incY ) ;
+
+FUNCTION: void cblas_cswap
+ ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
+FUNCTION: void cblas_ccopy
+ ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
+FUNCTION: void cblas_caxpy
+ ( int N, CBLAS_C* alpha, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
+
+FUNCTION: void cblas_zswap
+ ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
+FUNCTION: void cblas_zcopy
+ ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
+FUNCTION: void cblas_zaxpy
+ ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
+
+FUNCTION: void cblas_sscal
+ ( int N, float alpha, float* X, int incX ) ;
+FUNCTION: void cblas_dscal
+ ( int N, double alpha, double* X, int incX ) ;
+FUNCTION: void cblas_cscal
+ ( int N, CBLAS_C* alpha, CBLAS_C* X, int incX ) ;
+FUNCTION: void cblas_zscal
+ ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX ) ;
+FUNCTION: void cblas_csscal
+ ( int N, float alpha, CBLAS_C* X, int incX ) ;
+FUNCTION: void cblas_zdscal
+ ( int N, double alpha, CBLAS_Z* X, int incX ) ;
+
+FUNCTION: void cblas_srotg
+ ( float* a, float* b, float* c, float* s ) ;
+FUNCTION: void cblas_srotmg
+ ( float* d1, float* d2, float* b1, float b2, float* P ) ;
+FUNCTION: void cblas_srot
+ ( int N, float* X, int incX, float* Y, int incY, float c, float s ) ;
+FUNCTION: void cblas_srotm
+ ( int N, float* X, int incX, float* Y, int incY, float* P ) ;
+
+FUNCTION: void cblas_drotg
+ ( double* a, double* b, double* c, double* s ) ;
+FUNCTION: void cblas_drotmg
+ ( double* d1, double* d2, double* b1, double b2, double* P ) ;
+FUNCTION: void cblas_drot
+ ( int N, double* X, int incX, double* Y, int incY, double c, double s ) ;
+FUNCTION: void cblas_drotm
+ ( int N, double* X, int incX, double* Y, int incY, double* P ) ;
+
+! Level 2 BLAS (matrix-vector)
+
+FUNCTION: void cblas_sgemv ( CBLAS_ORDER Order,
+ CBLAS_TRANSPOSE TransA, int M, int N,
+ float alpha, float* A, int lda,
+ float* X, int incX, float beta,
+ float* Y, int incY ) ;
+FUNCTION: void cblas_sgbmv ( CBLAS_ORDER Order,
+ CBLAS_TRANSPOSE TransA, int M, int N,
+ int KL, int KU, float alpha,
+ float* A, int lda, float* X,
+ int incX, float beta, float* Y, int incY ) ;
+FUNCTION: void cblas_strmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, float* A, int lda,
+ float* X, int incX ) ;
+FUNCTION: void cblas_stbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, int K, float* A, int lda,
+ float* X, int incX ) ;
+FUNCTION: void cblas_stpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, float* Ap, float* X, int incX ) ;
+FUNCTION: void cblas_strsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, float* A, int lda, float* X,
+ int incX ) ;
+FUNCTION: void cblas_stbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, int K, float* A, int lda,
+ float* X, int incX ) ;
+FUNCTION: void cblas_stpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, float* Ap, float* X, int incX ) ;
+
+FUNCTION: void cblas_dgemv ( CBLAS_ORDER Order,
+ CBLAS_TRANSPOSE TransA, int M, int N,
+ double alpha, double* A, int lda,
+ double* X, int incX, double beta,
+ double* Y, int incY ) ;
+FUNCTION: void cblas_dgbmv ( CBLAS_ORDER Order,
+ CBLAS_TRANSPOSE TransA, int M, int N,
+ int KL, int KU, double alpha,
+ double* A, int lda, double* X,
+ int incX, double beta, double* Y, int incY ) ;
+FUNCTION: void cblas_dtrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, double* A, int lda,
+ double* X, int incX ) ;
+FUNCTION: void cblas_dtbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, int K, double* A, int lda,
+ double* X, int incX ) ;
+FUNCTION: void cblas_dtpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, double* Ap, double* X, int incX ) ;
+FUNCTION: void cblas_dtrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, double* A, int lda, double* X,
+ int incX ) ;
+FUNCTION: void cblas_dtbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, int K, double* A, int lda,
+ double* X, int incX ) ;
+FUNCTION: void cblas_dtpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, double* Ap, double* X, int incX ) ;
+
+FUNCTION: void cblas_cgemv ( CBLAS_ORDER Order,
+ CBLAS_TRANSPOSE TransA, int M, int N,
+ void* alpha, void* A, int lda,
+ void* X, int incX, void* beta,
+ void* Y, int incY ) ;
+FUNCTION: void cblas_cgbmv ( CBLAS_ORDER Order,
+ CBLAS_TRANSPOSE TransA, int M, int N,
+ int KL, int KU, void* alpha,
+ void* A, int lda, void* X,
+ int incX, void* beta, void* Y, int incY ) ;
+FUNCTION: void cblas_ctrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, void* A, int lda,
+ void* X, int incX ) ;
+FUNCTION: void cblas_ctbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, int K, void* A, int lda,
+ void* X, int incX ) ;
+FUNCTION: void cblas_ctpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, void* Ap, void* X, int incX ) ;
+FUNCTION: void cblas_ctrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, void* A, int lda, void* X,
+ int incX ) ;
+FUNCTION: void cblas_ctbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, int K, void* A, int lda,
+ void* X, int incX ) ;
+FUNCTION: void cblas_ctpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, void* Ap, void* X, int incX ) ;
+
+FUNCTION: void cblas_zgemv ( CBLAS_ORDER Order,
+ CBLAS_TRANSPOSE TransA, int M, int N,
+ void* alpha, void* A, int lda,
+ void* X, int incX, void* beta,
+ void* Y, int incY ) ;
+FUNCTION: void cblas_zgbmv ( CBLAS_ORDER Order,
+ CBLAS_TRANSPOSE TransA, int M, int N,
+ int KL, int KU, void* alpha,
+ void* A, int lda, void* X,
+ int incX, void* beta, void* Y, int incY ) ;
+FUNCTION: void cblas_ztrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, void* A, int lda,
+ void* X, int incX ) ;
+FUNCTION: void cblas_ztbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, int K, void* A, int lda,
+ void* X, int incX ) ;
+FUNCTION: void cblas_ztpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, void* Ap, void* X, int incX ) ;
+FUNCTION: void cblas_ztrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, void* A, int lda, void* X,
+ int incX ) ;
+FUNCTION: void cblas_ztbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, int K, void* A, int lda,
+ void* X, int incX ) ;
+FUNCTION: void cblas_ztpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
+ int N, void* Ap, void* X, int incX ) ;
+
+
+FUNCTION: void cblas_ssymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, float alpha, float* A,
+ int lda, float* X, int incX,
+ float beta, float* Y, int incY ) ;
+FUNCTION: void cblas_ssbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, int K, float alpha, float* A,
+ int lda, float* X, int incX,
+ float beta, float* Y, int incY ) ;
+FUNCTION: void cblas_sspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, float alpha, float* Ap,
+ float* X, int incX,
+ float beta, float* Y, int incY ) ;
+FUNCTION: void cblas_sger ( CBLAS_ORDER Order, int M, int N,
+ float alpha, float* X, int incX,
+ float* Y, int incY, float* A, int lda ) ;
+FUNCTION: void cblas_ssyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, float alpha, float* X,
+ int incX, float* A, int lda ) ;
+FUNCTION: void cblas_sspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, float alpha, float* X,
+ int incX, float* Ap ) ;
+FUNCTION: void cblas_ssyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, float alpha, float* X,
+ int incX, float* Y, int incY, float* A,
+ int lda ) ;
+FUNCTION: void cblas_sspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, float alpha, float* X,
+ int incX, float* Y, int incY, float* A ) ;
+
+FUNCTION: void cblas_dsymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, double alpha, double* A,
+ int lda, double* X, int incX,
+ double beta, double* Y, int incY ) ;
+FUNCTION: void cblas_dsbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, int K, double alpha, double* A,
+ int lda, double* X, int incX,
+ double beta, double* Y, int incY ) ;
+FUNCTION: void cblas_dspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, double alpha, double* Ap,
+ double* X, int incX,
+ double beta, double* Y, int incY ) ;
+FUNCTION: void cblas_dger ( CBLAS_ORDER Order, int M, int N,
+ double alpha, double* X, int incX,
+ double* Y, int incY, double* A, int lda ) ;
+FUNCTION: void cblas_dsyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, double alpha, double* X,
+ int incX, double* A, int lda ) ;
+FUNCTION: void cblas_dspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, double alpha, double* X,
+ int incX, double* Ap ) ;
+FUNCTION: void cblas_dsyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, double alpha, double* X,
+ int incX, double* Y, int incY, double* A,
+ int lda ) ;
+FUNCTION: void cblas_dspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, double alpha, double* X,
+ int incX, double* Y, int incY, double* A ) ;
+
+
+FUNCTION: void cblas_chemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, void* alpha, void* A,
+ int lda, void* X, int incX,
+ void* beta, void* Y, int incY ) ;
+FUNCTION: void cblas_chbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, int K, void* alpha, void* A,
+ int lda, void* X, int incX,
+ void* beta, void* Y, int incY ) ;
+FUNCTION: void cblas_chpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, void* alpha, void* Ap,
+ void* X, int incX,
+ void* beta, void* Y, int incY ) ;
+FUNCTION: void cblas_cgeru ( CBLAS_ORDER Order, int M, int N,
+ void* alpha, void* X, int incX,
+ void* Y, int incY, void* A, int lda ) ;
+FUNCTION: void cblas_cgerc ( CBLAS_ORDER Order, int M, int N,
+ void* alpha, void* X, int incX,
+ void* Y, int incY, void* A, int lda ) ;
+FUNCTION: void cblas_cher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, float alpha, void* X, int incX,
+ void* A, int lda ) ;
+FUNCTION: void cblas_chpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, float alpha, void* X,
+ int incX, void* A ) ;
+FUNCTION: void cblas_cher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
+ void* alpha, void* X, int incX,
+ void* Y, int incY, void* A, int lda ) ;
+FUNCTION: void cblas_chpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
+ void* alpha, void* X, int incX,
+ void* Y, int incY, void* Ap ) ;
+
+FUNCTION: void cblas_zhemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, void* alpha, void* A,
+ int lda, void* X, int incX,
+ void* beta, void* Y, int incY ) ;
+FUNCTION: void cblas_zhbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, int K, void* alpha, void* A,
+ int lda, void* X, int incX,
+ void* beta, void* Y, int incY ) ;
+FUNCTION: void cblas_zhpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, void* alpha, void* Ap,
+ void* X, int incX,
+ void* beta, void* Y, int incY ) ;
+FUNCTION: void cblas_zgeru ( CBLAS_ORDER Order, int M, int N,
+ void* alpha, void* X, int incX,
+ void* Y, int incY, void* A, int lda ) ;
+FUNCTION: void cblas_zgerc ( CBLAS_ORDER Order, int M, int N,
+ void* alpha, void* X, int incX,
+ void* Y, int incY, void* A, int lda ) ;
+FUNCTION: void cblas_zher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, double alpha, void* X, int incX,
+ void* A, int lda ) ;
+FUNCTION: void cblas_zhpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ int N, double alpha, void* X,
+ int incX, void* A ) ;
+FUNCTION: void cblas_zher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
+ void* alpha, void* X, int incX,
+ void* Y, int incY, void* A, int lda ) ;
+FUNCTION: void cblas_zhpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
+ void* alpha, void* X, int incX,
+ void* Y, int incY, void* Ap ) ;
+
+! Level 3 BLAS (matrix-matrix)
+
+FUNCTION: void cblas_sgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
+ CBLAS_TRANSPOSE TransB, int M, int N,
+ int K, float alpha, float* A,
+ int lda, float* B, int ldb,
+ float beta, float* C, int ldc ) ;
+FUNCTION: void cblas_ssymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, int M, int N,
+ float alpha, float* A, int lda,
+ float* B, int ldb, float beta,
+ float* C, int ldc ) ;
+FUNCTION: void cblas_ssyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ float alpha, float* A, int lda,
+ float beta, float* C, int ldc ) ;
+FUNCTION: void cblas_ssyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ float alpha, float* A, int lda,
+ float* B, int ldb, float beta,
+ float* C, int ldc ) ;
+FUNCTION: void cblas_strmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
+ CBLAS_DIAG Diag, int M, int N,
+ float alpha, float* A, int lda,
+ float* B, int ldb ) ;
+FUNCTION: void cblas_strsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
+ CBLAS_DIAG Diag, int M, int N,
+ float alpha, float* A, int lda,
+ float* B, int ldb ) ;
+
+FUNCTION: void cblas_dgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
+ CBLAS_TRANSPOSE TransB, int M, int N,
+ int K, double alpha, double* A,
+ int lda, double* B, int ldb,
+ double beta, double* C, int ldc ) ;
+FUNCTION: void cblas_dsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, int M, int N,
+ double alpha, double* A, int lda,
+ double* B, int ldb, double beta,
+ double* C, int ldc ) ;
+FUNCTION: void cblas_dsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ double alpha, double* A, int lda,
+ double beta, double* C, int ldc ) ;
+FUNCTION: void cblas_dsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ double alpha, double* A, int lda,
+ double* B, int ldb, double beta,
+ double* C, int ldc ) ;
+FUNCTION: void cblas_dtrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
+ CBLAS_DIAG Diag, int M, int N,
+ double alpha, double* A, int lda,
+ double* B, int ldb ) ;
+FUNCTION: void cblas_dtrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
+ CBLAS_DIAG Diag, int M, int N,
+ double alpha, double* A, int lda,
+ double* B, int ldb ) ;
+
+FUNCTION: void cblas_cgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
+ CBLAS_TRANSPOSE TransB, int M, int N,
+ int K, void* alpha, void* A,
+ int lda, void* B, int ldb,
+ void* beta, void* C, int ldc ) ;
+FUNCTION: void cblas_csymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, int M, int N,
+ void* alpha, void* A, int lda,
+ void* B, int ldb, void* beta,
+ void* C, int ldc ) ;
+FUNCTION: void cblas_csyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ void* alpha, void* A, int lda,
+ void* beta, void* C, int ldc ) ;
+FUNCTION: void cblas_csyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ void* alpha, void* A, int lda,
+ void* B, int ldb, void* beta,
+ void* C, int ldc ) ;
+FUNCTION: void cblas_ctrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
+ CBLAS_DIAG Diag, int M, int N,
+ void* alpha, void* A, int lda,
+ void* B, int ldb ) ;
+FUNCTION: void cblas_ctrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
+ CBLAS_DIAG Diag, int M, int N,
+ void* alpha, void* A, int lda,
+ void* B, int ldb ) ;
+
+FUNCTION: void cblas_zgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
+ CBLAS_TRANSPOSE TransB, int M, int N,
+ int K, void* alpha, void* A,
+ int lda, void* B, int ldb,
+ void* beta, void* C, int ldc ) ;
+FUNCTION: void cblas_zsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, int M, int N,
+ void* alpha, void* A, int lda,
+ void* B, int ldb, void* beta,
+ void* C, int ldc ) ;
+FUNCTION: void cblas_zsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ void* alpha, void* A, int lda,
+ void* beta, void* C, int ldc ) ;
+FUNCTION: void cblas_zsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ void* alpha, void* A, int lda,
+ void* B, int ldb, void* beta,
+ void* C, int ldc ) ;
+FUNCTION: void cblas_ztrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
+ CBLAS_DIAG Diag, int M, int N,
+ void* alpha, void* A, int lda,
+ void* B, int ldb ) ;
+FUNCTION: void cblas_ztrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
+ CBLAS_DIAG Diag, int M, int N,
+ void* alpha, void* A, int lda,
+ void* B, int ldb ) ;
+
+FUNCTION: void cblas_chemm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, int M, int N,
+ void* alpha, void* A, int lda,
+ void* B, int ldb, void* beta,
+ void* C, int ldc ) ;
+FUNCTION: void cblas_cherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ float alpha, void* A, int lda,
+ float beta, void* C, int ldc ) ;
+FUNCTION: void cblas_cher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ void* alpha, void* A, int lda,
+ void* B, int ldb, float beta,
+ void* C, int ldc ) ;
+FUNCTION: void cblas_zhemm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
+ CBLAS_UPLO Uplo, int M, int N,
+ void* alpha, void* A, int lda,
+ void* B, int ldb, void* beta,
+ void* C, int ldc ) ;
+FUNCTION: void cblas_zherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ double alpha, void* A, int lda,
+ double beta, void* C, int ldc ) ;
+FUNCTION: void cblas_zher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
+ CBLAS_TRANSPOSE Trans, int N, int K,
+ void* alpha, void* A, int lda,
+ void* B, int ldb, double beta,
+ void* C, int ldc ) ;
+
--- /dev/null
+Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library
--- /dev/null
+math
+bindings
+unportable
--- /dev/null
+USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
+IN: math.blas.matrices
+
+ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
+"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:"
+{ $subsection "math.blas-types" }
+"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
+{ $subsection "math.blas.vectors" }
+"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
+{ $subsection "math.blas.matrices" }
+"The low-level BLAS C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ;
+
+ARTICLE: "math.blas-types" "BLAS interface types"
+"BLAS vectors come in single- and double-precision, real and complex flavors:"
+{ $subsection float-blas-vector }
+{ $subsection double-blas-vector }
+{ $subsection float-complex-blas-vector }
+{ $subsection double-complex-blas-vector }
+"These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:"
+{ $subsection float-blas-matrix }
+{ $subsection double-blas-matrix }
+{ $subsection float-complex-blas-matrix }
+{ $subsection double-complex-blas-matrix }
+"Syntax words are provided for constructing literal vectors and matrices in the " { $vocab-link "math.blas.syntax" } " vocabulary:"
+{ $subsection "math.blas.syntax" }
+"There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
+{ $subsection <float-blas-vector> }
+{ $subsection <double-blas-vector> }
+{ $subsection <float-complex-blas-vector> }
+{ $subsection <double-complex-blas-vector> }
+{ $subsection <float-blas-matrix> }
+{ $subsection <double-blas-matrix> }
+{ $subsection <float-complex-blas-matrix> }
+{ $subsection <double-complex-blas-matrix> }
+"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
+{ $subsection <empty-vector> }
+{ $subsection <empty-matrix> }
+"BLAS vectors and matrices can also be constructed from other Factor sequences:"
+{ $subsection >float-blas-vector }
+{ $subsection >double-blas-vector }
+{ $subsection >float-complex-blas-vector }
+{ $subsection >double-complex-blas-vector }
+{ $subsection >float-blas-matrix }
+{ $subsection >double-blas-matrix }
+{ $subsection >float-complex-blas-matrix }
+{ $subsection >double-complex-blas-matrix } ;
+
+ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
+"Transposing and slicing matrices:"
+{ $subsection Mtranspose }
+{ $subsection Mrows }
+{ $subsection Mcols }
+{ $subsection Msub }
+"Matrix-vector products:"
+{ $subsection n*M.V+n*V! }
+{ $subsection n*M.V+n*V }
+{ $subsection n*M.V }
+{ $subsection M.V }
+"Vector outer products:"
+{ $subsection n*V(*)V+M! }
+{ $subsection n*V(*)Vconj+M! }
+{ $subsection n*V(*)V+M }
+{ $subsection n*V(*)Vconj+M }
+{ $subsection n*V(*)V }
+{ $subsection n*V(*)Vconj }
+{ $subsection V(*) }
+{ $subsection V(*)conj }
+"Matrix products:"
+{ $subsection n*M.M+n*M! }
+{ $subsection n*M.M+n*M }
+{ $subsection n*M.M }
+{ $subsection M. }
+"Scalar-matrix products:"
+{ $subsection n*M! }
+{ $subsection n*M }
+{ $subsection M*n }
+{ $subsection M/n } ;
+
+ABOUT: "math.blas.matrices"
+
+HELP: blas-matrix-base
+{ $class-description "The base class for all BLAS matrix types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:"
+{ $list
+ { { $link float-blas-matrix } }
+ { { $link double-blas-matrix } }
+ { { $link float-complex-blas-matrix } }
+ { { $link double-complex-blas-matrix } }
+}
+"All of these subclasses share the same tuple layout:"
+{ $list
+ { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" }
+ { { $snippet "ld" } " indicates the distance, in elements, between matrix columns;" }
+ { { $snippet "rows" } " and " { $snippet "cols" } " indicate the number of significant rows and columns in the matrix;" }
+ { "and " { $snippet "transpose" } ", if set to a true value, indicates that the matrix should be treated as transposed relative to its in-memory representation." }
+} } ;
+
+{ blas-vector-base blas-matrix-base } related-words
+
+HELP: float-blas-matrix
+{ $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
+HELP: double-blas-matrix
+{ $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
+HELP: float-complex-blas-matrix
+{ $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
+HELP: double-complex-blas-matrix
+{ $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
+
+{
+ float-blas-matrix double-blas-matrix float-complex-blas-matrix double-complex-blas-matrix
+ float-blas-vector double-blas-vector float-complex-blas-vector double-complex-blas-vector
+} related-words
+
+HELP: Mwidth
+{ $values { "matrix" blas-matrix-base } { "width" integer } }
+{ $description "Returns the number of columns in " { $snippet "matrix" } "." } ;
+
+HELP: Mheight
+{ $values { "matrix" blas-matrix-base } { "height" integer } }
+{ $description "Returns the number of rows in " { $snippet "matrix" } "." } ;
+
+{ Mwidth Mheight } related-words
+
+HELP: n*M.V+n*V!
+{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "y=alpha*A.x+b*y" blas-vector-base } }
+{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } ", and overwrite the current contents of " { $snippet "y" } " with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." }
+{ $side-effects "y" } ;
+
+HELP: n*V(*)V+M!
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)y+A" blas-matrix-base } }
+{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGER and xGERU routines in BLAS." }
+{ $side-effects "A" } ;
+
+HELP: n*V(*)Vconj+M!
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)yconj+A" blas-matrix-base } }
+{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGERC routines in BLAS." }
+{ $side-effects "A" } ;
+
+HELP: n*M.M+n*M!
+{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "C=alpha*A.B+beta*C" blas-matrix-base } }
+{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." }
+{ $side-effects "C" } ;
+
+HELP: <empty-matrix>
+{ $values { "rows" integer } { "cols" integer } { "exemplar" blas-vector-base blas-matrix-base } { "matrix" blas-matrix-base } }
+{ $description "Create a matrix of all zeros with the given dimensions and the same element type as " { $snippet "exemplar" } "." } ;
+
+{ <zero-vector> <empty-vector> <empty-matrix> } related-words
+
+HELP: n*M.V+n*V
+{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "alpha*A.x+b*y" blas-vector-base } }
+{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". The returned vector will have the same length as " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } ;
+
+HELP: n*V(*)V+M
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)y+A" blas-matrix-base } }
+{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
+
+HELP: n*V(*)Vconj+M
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)yconj+A" blas-matrix-base } }
+{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGERC routines in BLAS." } ;
+
+HELP: n*M.M+n*M
+{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "alpha*A.B+beta*C" blas-matrix-base } }
+{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ;
+
+HELP: n*M.V
+{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "alpha*A.x" blas-vector-base } }
+{ $description "Calculate the matrix-vector product " { $snippet "αAx" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
+
+HELP: M.V
+{ $values { "A" blas-matrix-base } { "x" blas-vector-base } { "A.x" blas-vector-base } }
+{ $description "Calculate the matrix-vector product " { $snippet "Ax" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
+
+{ n*M.V+n*V! n*M.V+n*V n*M.V M.V } related-words
+
+HELP: n*V(*)V
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)y" blas-matrix-base } }
+{ $description "Calculate the outer product " { $snippet "αx⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
+
+HELP: n*V(*)Vconj
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)yconj" blas-matrix-base } }
+{ $description "Calculate the outer product " { $snippet "αx⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
+
+HELP: V(*)
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)y" blas-matrix-base } }
+{ $description "Calculate the outer product " { $snippet "x⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
+
+HELP: V(*)conj
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)yconj" blas-matrix-base } }
+{ $description "Calculate the conjugate outer product " { $snippet "x⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
+
+{ n*V(*)V+M! n*V(*)Vconj+M! n*V(*)V+M n*V(*)Vconj+M n*V(*)V n*V(*)Vconj V(*) V(*)conj V. V.conj } related-words
+
+HELP: n*M.M
+{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "alpha*A.B" blas-matrix-base } }
+{ $description "Calculate the matrix product " { $snippet "αAB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
+
+HELP: M.
+{ $values { "A" blas-matrix-base } { "B" blas-matrix-base } { "A.B" blas-matrix-base } }
+{ $description "Calculate the matrix product " { $snippet "AB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
+
+{ n*M.M+n*M! n*M.M+n*M n*M.M M. } related-words
+
+HELP: Msub
+{ $values { "matrix" blas-matrix-base } { "row" integer } { "col" integer } { "height" integer } { "width" integer } { "sub" blas-matrix-base } }
+{ $description "Select a rectangular submatrix of " { $snippet "matrix" } " with the given dimensions. The returned submatrix will share the parent matrix's storage." } ;
+
+HELP: Mrows
+{ $values { "A" blas-matrix-base } { "rows" sequence } }
+{ $description "Return a sequence of BLAS vectors representing the rows of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
+
+HELP: Mcols
+{ $values { "A" blas-matrix-base } { "cols" sequence } }
+{ $description "Return a sequence of BLAS vectors representing the columns of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
+
+HELP: n*M!
+{ $values { "n" number } { "A" blas-matrix-base } { "A=n*A" blas-matrix-base } }
+{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and overwrite the current contents of A with the result." }
+{ $side-effects "A" } ;
+
+HELP: n*M
+{ $values { "n" number } { "A" blas-matrix-base } { "n*A" blas-matrix-base } }
+{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
+
+HELP: M*n
+{ $values { "A" blas-matrix-base } { "n" number } { "A*n" blas-matrix-base } }
+{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
+
+HELP: M/n
+{ $values { "A" blas-matrix-base } { "n" number } { "A/n" blas-matrix-base } }
+{ $description "Calculate the scalar-matrix product " { $snippet "(1/n)A" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
+
+{ n*M! n*M M*n M/n } related-words
+
+HELP: Mtranspose
+{ $values { "matrix" blas-matrix-base } { "matrix^T" blas-matrix-base } }
+{ $description "Returns the transpose of " { $snippet "matrix" } ". The returned matrix shares storage with the original matrix." } ;
+
+HELP: element-type
+{ $values { "v" blas-vector-base blas-matrix-base } { "type" string } }
+{ $description "Return the C type of the elements in the given BLAS vector or matrix." } ;
+
+HELP: <empty-vector>
+{ $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } }
+{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
+
--- /dev/null
+USING: kernel math.blas.matrices math.blas.vectors math.blas.syntax
+sequences tools.test ;
+IN: math.blas.matrices.tests
+
+! clone
+
+[ smatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+} ] [
+ smatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+ } clone
+] unit-test
+[ f ] [
+ smatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+ } dup clone eq?
+] unit-test
+
+[ dmatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+} ] [
+ dmatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+ } clone
+] unit-test
+[ f ] [
+ dmatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+ } dup clone eq?
+] unit-test
+
+[ cmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+} ] [
+ cmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+ } clone
+] unit-test
+[ f ] [
+ cmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+ } dup clone eq?
+] unit-test
+
+[ zmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+} ] [
+ zmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+ } clone
+] unit-test
+[ f ] [
+ zmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+ } dup clone eq?
+] unit-test
+
+! M.V
+
+[ svector{ 3.0 1.0 6.0 } ] [
+ smatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 0.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ }
+ svector{ 1.0 2.0 3.0 1.0 }
+ M.V
+] unit-test
+[ svector{ -2.0 1.0 3.0 14.0 } ] [
+ smatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 0.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ } Mtranspose
+ svector{ 1.0 2.0 3.0 }
+ M.V
+] unit-test
+
+[ dvector{ 3.0 1.0 6.0 } ] [
+ dmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 0.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ }
+ dvector{ 1.0 2.0 3.0 1.0 }
+ M.V
+] unit-test
+[ dvector{ -2.0 1.0 3.0 14.0 } ] [
+ dmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 0.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ } Mtranspose
+ dvector{ 1.0 2.0 3.0 }
+ M.V
+] unit-test
+
+[ cvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [
+ cmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ }
+ cvector{ 1.0 2.0 3.0 1.0 }
+ M.V
+] unit-test
+[ cvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [
+ cmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ } Mtranspose
+ cvector{ 1.0 2.0 3.0 }
+ M.V
+] unit-test
+
+[ zvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [
+ zmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ }
+ zvector{ 1.0 2.0 3.0 1.0 }
+ M.V
+] unit-test
+[ zvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [
+ zmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ } Mtranspose
+ zvector{ 1.0 2.0 3.0 }
+ M.V
+] unit-test
+
+! V(*)
+
+[ smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 4.0 6.0 8.0 }
+ { 3.0 6.0 9.0 12.0 }
+} ] [
+ svector{ 1.0 2.0 3.0 } svector{ 1.0 2.0 3.0 4.0 } V(*)
+] unit-test
+
+[ dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 4.0 6.0 8.0 }
+ { 3.0 6.0 9.0 12.0 }
+} ] [
+ dvector{ 1.0 2.0 3.0 } dvector{ 1.0 2.0 3.0 4.0 } V(*)
+] unit-test
+
+[ cmatrix{
+ { 1.0 2.0 C{ 3.0 -3.0 } 4.0 }
+ { 2.0 4.0 C{ 6.0 -6.0 } 8.0 }
+ { C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } }
+} ] [
+ cvector{ 1.0 2.0 C{ 3.0 3.0 } } cvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*)
+] unit-test
+
+[ zmatrix{
+ { 1.0 2.0 C{ 3.0 -3.0 } 4.0 }
+ { 2.0 4.0 C{ 6.0 -6.0 } 8.0 }
+ { C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } }
+} ] [
+ zvector{ 1.0 2.0 C{ 3.0 3.0 } } zvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*)
+] unit-test
+
+! M.
+
+[ smatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 0.0 -3.0 0.0 0.0 }
+ { 0.0 4.0 0.0 0.0 10.0 }
+ { 0.0 0.0 0.0 0.0 0.0 }
+} ] [
+ smatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } smatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 2.0 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } M.
+] unit-test
+
+[ smatrix{
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 4.0 0.0 }
+ { 0.0 -3.0 0.0 0.0 }
+ { 4.0 0.0 0.0 0.0 }
+ { 0.0 0.0 10.0 0.0 }
+} ] [
+ smatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 2.0 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } Mtranspose smatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } Mtranspose M.
+] unit-test
+
+[ dmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 0.0 -3.0 0.0 0.0 }
+ { 0.0 4.0 0.0 0.0 10.0 }
+ { 0.0 0.0 0.0 0.0 0.0 }
+} ] [
+ dmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } dmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 2.0 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } M.
+] unit-test
+
+[ dmatrix{
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 4.0 0.0 }
+ { 0.0 -3.0 0.0 0.0 }
+ { 4.0 0.0 0.0 0.0 }
+ { 0.0 0.0 10.0 0.0 }
+} ] [
+ dmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 2.0 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } Mtranspose dmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } Mtranspose M.
+] unit-test
+
+[ cmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 0.0 -3.0 0.0 0.0 }
+ { 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 }
+ { 0.0 0.0 0.0 0.0 0.0 }
+} ] [
+ cmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } cmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } M.
+] unit-test
+
+[ cmatrix{
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 C{ 4.0 -4.0 } 0.0 }
+ { 0.0 -3.0 0.0 0.0 }
+ { 4.0 0.0 0.0 0.0 }
+ { 0.0 0.0 10.0 0.0 }
+} ] [
+ cmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } Mtranspose cmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } Mtranspose M.
+] unit-test
+
+[ zmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 0.0 -3.0 0.0 0.0 }
+ { 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 }
+ { 0.0 0.0 0.0 0.0 0.0 }
+} ] [
+ zmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } zmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } M.
+] unit-test
+
+[ zmatrix{
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 C{ 4.0 -4.0 } 0.0 }
+ { 0.0 -3.0 0.0 0.0 }
+ { 4.0 0.0 0.0 0.0 }
+ { 0.0 0.0 10.0 0.0 }
+} ] [
+ zmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } Mtranspose zmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } Mtranspose M.
+] unit-test
+
+! n*M
+
+[ smatrix{
+ { 2.0 0.0 }
+ { 0.0 2.0 }
+} ] [
+ 2.0 smatrix{
+ { 1.0 0.0 }
+ { 0.0 1.0 }
+ } n*M
+] unit-test
+
+[ dmatrix{
+ { 2.0 0.0 }
+ { 0.0 2.0 }
+} ] [
+ 2.0 dmatrix{
+ { 1.0 0.0 }
+ { 0.0 1.0 }
+ } n*M
+] unit-test
+
+[ cmatrix{
+ { C{ 2.0 1.0 } 0.0 }
+ { 0.0 C{ -1.0 2.0 } }
+} ] [
+ C{ 2.0 1.0 } cmatrix{
+ { 1.0 0.0 }
+ { 0.0 C{ 0.0 1.0 } }
+ } n*M
+] unit-test
+
+[ zmatrix{
+ { C{ 2.0 1.0 } 0.0 }
+ { 0.0 C{ -1.0 2.0 } }
+} ] [
+ C{ 2.0 1.0 } zmatrix{
+ { 1.0 0.0 }
+ { 0.0 C{ 0.0 1.0 } }
+ } n*M
+] unit-test
+
+! Mrows, Mcols
+
+[ svector{ 3.0 3.0 3.0 } ] [
+ 2 smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mcols nth
+] unit-test
+[ svector{ 3.0 2.0 3.0 4.0 } ] [
+ 2 smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mrows nth
+] unit-test
+[ 3 ] [
+ smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mrows length
+] unit-test
+[ 4 ] [
+ smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mcols length
+] unit-test
+[ svector{ 3.0 3.0 3.0 } ] [
+ 2 smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mrows nth
+] unit-test
+[ svector{ 3.0 2.0 3.0 4.0 } ] [
+ 2 smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mcols nth
+] unit-test
+[ 3 ] [
+ smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mcols length
+] unit-test
+[ 4 ] [
+ smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mrows length
+] unit-test
+
+[ dvector{ 3.0 3.0 3.0 } ] [
+ 2 dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mcols nth
+] unit-test
+[ dvector{ 3.0 2.0 3.0 4.0 } ] [
+ 2 dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mrows nth
+] unit-test
+[ 3 ] [
+ dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mrows length
+] unit-test
+[ 4 ] [
+ dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mcols length
+] unit-test
+[ dvector{ 3.0 3.0 3.0 } ] [
+ 2 dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mrows nth
+] unit-test
+[ dvector{ 3.0 2.0 3.0 4.0 } ] [
+ 2 dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mcols nth
+] unit-test
+[ 3 ] [
+ dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mcols length
+] unit-test
+[ 4 ] [
+ dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mrows length
+] unit-test
+
+[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
+ 2 cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mcols nth
+] unit-test
+[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
+ 2 cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mrows nth
+] unit-test
+[ 3 ] [
+ cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mrows length
+] unit-test
+[ 4 ] [
+ cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mcols length
+] unit-test
+[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
+ 2 cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mrows nth
+] unit-test
+[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
+ 2 cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mcols nth
+] unit-test
+[ 3 ] [
+ cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mcols length
+] unit-test
+[ 4 ] [
+ cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mrows length
+] unit-test
+
+[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
+ 2 zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mcols nth
+] unit-test
+[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
+ 2 zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mrows nth
+] unit-test
+[ 3 ] [
+ zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mrows length
+] unit-test
+[ 4 ] [
+ zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mcols length
+] unit-test
+[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
+ 2 zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mrows nth
+] unit-test
+[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
+ 2 zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mcols nth
+] unit-test
+[ 3 ] [
+ zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mcols length
+] unit-test
+[ 4 ] [
+ zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mrows length
+] unit-test
+
+! Msub
+
+[ smatrix{
+ { 3.0 2.0 1.0 }
+ { 0.0 1.0 0.0 }
+} ] [
+ smatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 3.0 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } 1 2 2 3 Msub
+] unit-test
+
+[ smatrix{
+ { 3.0 0.0 }
+ { 2.0 1.0 }
+ { 1.0 0.0 }
+} ] [
+ smatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 3.0 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } Mtranspose 2 1 3 2 Msub
+] unit-test
+
+[ dmatrix{
+ { 3.0 2.0 1.0 }
+ { 0.0 1.0 0.0 }
+} ] [
+ dmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 3.0 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } 1 2 2 3 Msub
+] unit-test
+
+[ dmatrix{
+ { 3.0 0.0 }
+ { 2.0 1.0 }
+ { 1.0 0.0 }
+} ] [
+ dmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 3.0 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } Mtranspose 2 1 3 2 Msub
+] unit-test
+
+[ cmatrix{
+ { C{ 3.0 3.0 } 2.0 1.0 }
+ { 0.0 1.0 0.0 }
+} ] [
+ cmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } 1 2 2 3 Msub
+] unit-test
+
+[ cmatrix{
+ { C{ 3.0 3.0 } 0.0 }
+ { 2.0 1.0 }
+ { 1.0 0.0 }
+} ] [
+ cmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } Mtranspose 2 1 3 2 Msub
+] unit-test
+
+[ zmatrix{
+ { C{ 3.0 3.0 } 2.0 1.0 }
+ { 0.0 1.0 0.0 }
+} ] [
+ zmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } 1 2 2 3 Msub
+] unit-test
+
+[ zmatrix{
+ { C{ 3.0 3.0 } 0.0 }
+ { 2.0 1.0 }
+ { 1.0 0.0 }
+} ] [
+ zmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } Mtranspose 2 1 3 2 Msub
+] unit-test
+
--- /dev/null
+USING: accessors alien alien.c-types arrays byte-arrays combinators
+combinators.lib combinators.short-circuit fry kernel locals macros
+math math.blas.cblas math.blas.vectors math.blas.vectors.private
+math.complex math.functions math.order multi-methods qualified
+sequences sequences.merged sequences.private generalizations
+shuffle symbols speicalized-arrays.float specialized-arrays.double ;
+QUALIFIED: syntax
+IN: math.blas.matrices
+
+TUPLE: blas-matrix-base data ld rows cols transpose ;
+TUPLE: float-blas-matrix < blas-matrix-base ;
+TUPLE: double-blas-matrix < blas-matrix-base ;
+TUPLE: float-complex-blas-matrix < blas-matrix-base ;
+TUPLE: double-complex-blas-matrix < blas-matrix-base ;
+
+C: <float-blas-matrix> float-blas-matrix
+C: <double-blas-matrix> double-blas-matrix
+C: <float-complex-blas-matrix> float-complex-blas-matrix
+C: <double-complex-blas-matrix> double-complex-blas-matrix
+
+METHOD: element-type { float-blas-matrix }
+ drop "float" ;
+METHOD: element-type { double-blas-matrix }
+ drop "double" ;
+METHOD: element-type { float-complex-blas-matrix }
+ drop "CBLAS_C" ;
+METHOD: element-type { double-complex-blas-matrix }
+ drop "CBLAS_Z" ;
+
+: Mtransposed? ( matrix -- ? )
+ transpose>> ; inline
+: Mwidth ( matrix -- width )
+ dup Mtransposed? [ rows>> ] [ cols>> ] if ; inline
+: Mheight ( matrix -- height )
+ dup Mtransposed? [ cols>> ] [ rows>> ] if ; inline
+
+<PRIVATE
+
+: (blas-transpose) ( matrix -- integer )
+ transpose>> [ CblasTrans ] [ CblasNoTrans ] if ;
+
+GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
+
+METHOD: (blas-matrix-like) { object object object object object float-blas-matrix }
+ drop <float-blas-matrix> ;
+METHOD: (blas-matrix-like) { object object object object object double-blas-matrix }
+ drop <double-blas-matrix> ;
+METHOD: (blas-matrix-like) { object object object object object float-complex-blas-matrix }
+ drop <float-complex-blas-matrix> ;
+METHOD: (blas-matrix-like) { object object object object object double-complex-blas-matrix }
+ drop <double-complex-blas-matrix> ;
+
+METHOD: (blas-matrix-like) { object object object object object float-blas-vector }
+ drop <float-blas-matrix> ;
+METHOD: (blas-matrix-like) { object object object object object double-blas-vector }
+ drop <double-blas-matrix> ;
+METHOD: (blas-matrix-like) { object object object object object float-complex-blas-vector }
+ drop <float-complex-blas-matrix> ;
+METHOD: (blas-matrix-like) { object object object object object double-complex-blas-vector }
+ drop <double-complex-blas-matrix> ;
+
+METHOD: (blas-vector-like) { object object object float-blas-matrix }
+ drop <float-blas-vector> ;
+METHOD: (blas-vector-like) { object object object double-blas-matrix }
+ drop <double-blas-vector> ;
+METHOD: (blas-vector-like) { object object object float-complex-blas-matrix }
+ drop <float-complex-blas-vector> ;
+METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
+ drop <double-complex-blas-vector> ;
+
+: (validate-gemv) ( A x y -- )
+ {
+ [ drop [ Mwidth ] [ length>> ] bi* = ]
+ [ nip [ Mheight ] [ length>> ] bi* = ]
+ } 3&&
+ [ "Mismatched matrix and vectors in matrix-vector multiplication" throw ] unless ;
+
+:: (prepare-gemv) ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc y )
+ A x y (validate-gemv)
+ CblasColMajor
+ A (blas-transpose)
+ A rows>>
+ A cols>>
+ alpha >c-arg call
+ A data>>
+ A ld>>
+ x data>>
+ x inc>>
+ beta >c-arg call
+ y data>>
+ y inc>>
+ y ; inline
+
+: (validate-ger) ( x y A -- )
+ {
+ [ nip [ length>> ] [ Mheight ] bi* = ]
+ [ nipd [ length>> ] [ Mwidth ] bi* = ]
+ } 3&&
+ [ "Mismatched vertices and matrix in vector outer product" throw ] unless ;
+
+:: (prepare-ger) ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld A )
+ x y A (validate-ger)
+ CblasColMajor
+ A rows>>
+ A cols>>
+ alpha >c-arg call
+ x data>>
+ x inc>>
+ y data>>
+ y inc>>
+ A data>>
+ A ld>>
+ A f >>transpose ; inline
+
+: (validate-gemm) ( A B C -- )
+ {
+ [ drop [ Mwidth ] [ Mheight ] bi* = ]
+ [ nip [ Mheight ] bi@ = ]
+ [ nipd [ Mwidth ] bi@ = ]
+ } 3&& [ "Mismatched matrices in matrix multiplication" throw ] unless ;
+
+:: (prepare-gemm) ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld C )
+ A B C (validate-gemm)
+ CblasColMajor
+ A (blas-transpose)
+ B (blas-transpose)
+ C rows>>
+ C cols>>
+ A Mwidth
+ alpha >c-arg call
+ A data>>
+ A ld>>
+ B data>>
+ B ld>>
+ beta >c-arg call
+ C data>>
+ C ld>>
+ C f >>transpose ; inline
+
+: (>matrix) ( arrays >c-array -- c-array ld rows cols transpose )
+ '[ <merged> @ ] [ length dup ] [ first length ] tri f ; inline
+
+PRIVATE>
+
+: >float-blas-matrix ( arrays -- matrix )
+ [ >float-array underlying>> ] (>matrix) <float-blas-matrix> ;
+: >double-blas-matrix ( arrays -- matrix )
+ [ >double-array underlying>> ] (>matrix) <double-blas-matrix> ;
+: >float-complex-blas-matrix ( arrays -- matrix )
+ [ (flatten-complex-sequence) >float-array underlying>> ] (>matrix)
+ <float-complex-blas-matrix> ;
+: >double-complex-blas-matrix ( arrays -- matrix )
+ [ (flatten-complex-sequence) >double-array underlying>> ] (>matrix)
+ <double-complex-blas-matrix> ;
+
+GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
+GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
+GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
+GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
+
+METHOD: n*M.V+n*V! { real float-blas-matrix float-blas-vector real float-blas-vector }
+ [ ] (prepare-gemv) [ cblas_sgemv ] dip ;
+METHOD: n*M.V+n*V! { real double-blas-matrix double-blas-vector real double-blas-vector }
+ [ ] (prepare-gemv) [ cblas_dgemv ] dip ;
+METHOD: n*M.V+n*V! { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector }
+ [ (>c-complex) ] (prepare-gemv) [ cblas_cgemv ] dip ;
+METHOD: n*M.V+n*V! { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector }
+ [ (>z-complex) ] (prepare-gemv) [ cblas_zgemv ] dip ;
+
+METHOD: n*V(*)V+M! { real float-blas-vector float-blas-vector float-blas-matrix }
+ [ ] (prepare-ger) [ cblas_sger ] dip ;
+METHOD: n*V(*)V+M! { real double-blas-vector double-blas-vector double-blas-matrix }
+ [ ] (prepare-ger) [ cblas_dger ] dip ;
+METHOD: n*V(*)V+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
+ [ (>c-complex) ] (prepare-ger) [ cblas_cgeru ] dip ;
+METHOD: n*V(*)V+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
+ [ (>z-complex) ] (prepare-ger) [ cblas_zgeru ] dip ;
+
+METHOD: n*V(*)Vconj+M! { real float-blas-vector float-blas-vector float-blas-matrix }
+ [ ] (prepare-ger) [ cblas_sger ] dip ;
+METHOD: n*V(*)Vconj+M! { real double-blas-vector double-blas-vector double-blas-matrix }
+ [ ] (prepare-ger) [ cblas_dger ] dip ;
+METHOD: n*V(*)Vconj+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
+ [ (>c-complex) ] (prepare-ger) [ cblas_cgerc ] dip ;
+METHOD: n*V(*)Vconj+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
+ [ (>z-complex) ] (prepare-ger) [ cblas_zgerc ] dip ;
+
+METHOD: n*M.M+n*M! { real float-blas-matrix float-blas-matrix real float-blas-matrix }
+ [ ] (prepare-gemm) [ cblas_sgemm ] dip ;
+METHOD: n*M.M+n*M! { real double-blas-matrix double-blas-matrix real double-blas-matrix }
+ [ ] (prepare-gemm) [ cblas_dgemm ] dip ;
+METHOD: n*M.M+n*M! { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix }
+ [ (>c-complex) ] (prepare-gemm) [ cblas_cgemm ] dip ;
+METHOD: n*M.M+n*M! { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix }
+ [ (>z-complex) ] (prepare-gemm) [ cblas_zgemm ] dip ;
+
+! XXX should do a dense clone
+syntax:M: blas-matrix-base clone
+ [
+ [
+ { [ data>> ] [ ld>> ] [ cols>> ] [ element-type heap-size ] } cleave
+ * * memory>byte-array
+ ] [ { [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> ] } cleave ] bi
+ ] keep (blas-matrix-like) ;
+
+! XXX try rounding stride to next 128 bit bound for better vectorizin'
+: <empty-matrix> ( rows cols exemplar -- matrix )
+ [ element-type [ * ] dip <c-array> ]
+ [ 2drop ]
+ [ f swap (blas-matrix-like) ] 3tri ;
+
+: n*M.V+n*V ( alpha A x beta y -- alpha*A.x+b*y )
+ clone n*M.V+n*V! ;
+: n*V(*)V+M ( alpha x y A -- alpha*x(*)y+A )
+ clone n*V(*)V+M! ;
+: n*V(*)Vconj+M ( alpha x y A -- alpha*x(*)yconj+A )
+ clone n*V(*)Vconj+M! ;
+: n*M.M+n*M ( alpha A B beta C -- alpha*A.B+beta*C )
+ clone n*M.M+n*M! ;
+
+: n*M.V ( alpha A x -- alpha*A.x )
+ 1.0 2over [ Mheight ] dip <empty-vector>
+ n*M.V+n*V! ; inline
+
+: M.V ( A x -- A.x )
+ 1.0 -rot n*M.V ; inline
+
+: n*V(*)V ( alpha x y -- alpha*x(*)y )
+ 2dup [ length>> ] bi@ pick <empty-matrix>
+ n*V(*)V+M! ;
+: n*V(*)Vconj ( alpha x y -- alpha*x(*)yconj )
+ 2dup [ length>> ] bi@ pick <empty-matrix>
+ n*V(*)Vconj+M! ;
+
+: V(*) ( x y -- x(*)y )
+ 1.0 -rot n*V(*)V ; inline
+: V(*)conj ( x y -- x(*)yconj )
+ 1.0 -rot n*V(*)Vconj ; inline
+
+: n*M.M ( alpha A B -- alpha*A.B )
+ 2dup [ Mheight ] [ Mwidth ] bi* pick <empty-matrix>
+ 1.0 swap n*M.M+n*M! ;
+
+: M. ( A B -- A.B )
+ 1.0 -rot n*M.M ; inline
+
+:: (Msub) ( matrix row col height width -- data ld rows cols )
+ matrix ld>> col * row + matrix element-type heap-size *
+ matrix data>> <displaced-alien>
+ matrix ld>>
+ height
+ width ;
+
+: Msub ( matrix row col height width -- sub )
+ 5 npick dup transpose>>
+ [ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep
+ swap (blas-matrix-like) ;
+
+TUPLE: blas-matrix-rowcol-sequence parent inc rowcol-length rowcol-jump length ;
+C: <blas-matrix-rowcol-sequence> blas-matrix-rowcol-sequence
+
+INSTANCE: blas-matrix-rowcol-sequence sequence
+
+syntax:M: blas-matrix-rowcol-sequence length
+ length>> ;
+syntax:M: blas-matrix-rowcol-sequence nth-unsafe
+ {
+ [
+ [ rowcol-jump>> ]
+ [ parent>> element-type heap-size ]
+ [ parent>> data>> ] tri
+ [ * * ] dip <displaced-alien>
+ ]
+ [ rowcol-length>> ]
+ [ inc>> ]
+ [ parent>> ]
+ } cleave (blas-vector-like) ;
+
+: (Mcols) ( A -- columns )
+ { [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] } cleave
+ <blas-matrix-rowcol-sequence> ;
+: (Mrows) ( A -- rows )
+ { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] } cleave
+ <blas-matrix-rowcol-sequence> ;
+
+: Mrows ( A -- rows )
+ dup transpose>> [ (Mcols) ] [ (Mrows) ] if ;
+: Mcols ( A -- cols )
+ dup transpose>> [ (Mrows) ] [ (Mcols) ] if ;
+
+: n*M! ( n A -- A=n*A )
+ [ (Mcols) [ n*V! drop ] with each ] keep ;
+
+: n*M ( n A -- n*A )
+ clone n*M! ; inline
+
+: M*n ( A n -- A*n )
+ swap n*M ; inline
+: M/n ( A n -- A/n )
+ recip swap n*M ; inline
+
+: Mtranspose ( matrix -- matrix^T )
+ [ { [ data>> ] [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> not ] } cleave ] keep (blas-matrix-like) ;
+
+syntax:M: blas-matrix-base equal?
+ {
+ [ [ Mwidth ] bi@ = ]
+ [ [ Mcols ] bi@ [ = ] 2all? ]
+ } 2&& ;
+
--- /dev/null
+BLAS level 2 and 3 matrix-vector and matrix-matrix operations
--- /dev/null
+math
+bindings
+unportable
--- /dev/null
+Literal syntax for BLAS vectors and matrices
--- /dev/null
+USING: help.markup help.syntax math.blas.matrices math.blas.vectors multiline ;
+IN: math.blas.syntax
+
+ARTICLE: "math.blas.syntax" "BLAS interface literal syntax"
+"Vectors:"
+{ $subsection POSTPONE: svector{ }
+{ $subsection POSTPONE: dvector{ }
+{ $subsection POSTPONE: cvector{ }
+{ $subsection POSTPONE: zvector{ }
+"Matrices:"
+{ $subsection POSTPONE: smatrix{ }
+{ $subsection POSTPONE: dmatrix{ }
+{ $subsection POSTPONE: cmatrix{ }
+{ $subsection POSTPONE: zmatrix{ } ;
+
+ABOUT: "math.blas.syntax"
+
+HELP: svector{
+{ $syntax "svector{ 1.0 -2.0 3.0 }" }
+{ $description "Construct a literal " { $link float-blas-vector } "." } ;
+
+HELP: dvector{
+{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
+{ $description "Construct a literal " { $link double-blas-vector } "." } ;
+
+HELP: cvector{
+{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
+{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
+
+HELP: zvector{
+{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
+{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
+
+{
+ POSTPONE: svector{ POSTPONE: dvector{
+ POSTPONE: cvector{ POSTPONE: zvector{
+} related-words
+
+HELP: smatrix{
+{ $syntax <" smatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 1.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ { 0.0 0.0 0.0 1.0 }
+} "> }
+{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: dmatrix{
+{ $syntax <" dmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 1.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ { 0.0 0.0 0.0 1.0 }
+} "> }
+{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: cmatrix{
+{ $syntax <" cmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 -1.0 3.0 }
+ { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
+} "> }
+{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: zmatrix{
+{ $syntax <" zmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 -1.0 3.0 }
+ { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
+} "> }
+{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+{
+ POSTPONE: smatrix{ POSTPONE: dmatrix{
+ POSTPONE: cmatrix{ POSTPONE: zmatrix{
+} related-words
--- /dev/null
+USING: kernel math.blas.matrices math.blas.vectors parser
+arrays prettyprint.backend sequences ;
+IN: math.blas.syntax
+
+: svector{
+ \ } [ >float-blas-vector ] parse-literal ; parsing
+: dvector{
+ \ } [ >double-blas-vector ] parse-literal ; parsing
+: cvector{
+ \ } [ >float-complex-blas-vector ] parse-literal ; parsing
+: zvector{
+ \ } [ >double-complex-blas-vector ] parse-literal ; parsing
+
+: smatrix{
+ \ } [ >float-blas-matrix ] parse-literal ; parsing
+: dmatrix{
+ \ } [ >double-blas-matrix ] parse-literal ; parsing
+: cmatrix{
+ \ } [ >float-complex-blas-matrix ] parse-literal ; parsing
+: zmatrix{
+ \ } [ >double-complex-blas-matrix ] parse-literal ; parsing
+
+M: float-blas-vector pprint-delims drop \ svector{ \ } ;
+M: double-blas-vector pprint-delims drop \ dvector{ \ } ;
+M: float-complex-blas-vector pprint-delims drop \ cvector{ \ } ;
+M: double-complex-blas-vector pprint-delims drop \ zvector{ \ } ;
+
+M: float-blas-matrix pprint-delims drop \ smatrix{ \ } ;
+M: double-blas-matrix pprint-delims drop \ dmatrix{ \ } ;
+M: float-complex-blas-matrix pprint-delims drop \ cmatrix{ \ } ;
+M: double-complex-blas-matrix pprint-delims drop \ zmatrix{ \ } ;
+
+M: blas-vector-base >pprint-sequence ;
+M: blas-vector-base pprint* pprint-object ;
+M: blas-matrix-base >pprint-sequence Mrows ;
+M: blas-matrix-base pprint* pprint-object ;
--- /dev/null
+math
+unportable
--- /dev/null
+BLAS level 1 vector operations
--- /dev/null
+math
+unportable
--- /dev/null
+USING: alien byte-arrays help.markup help.syntax math sequences ;
+IN: math.blas.vectors
+
+ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
+"Slicing vectors:"
+{ $subsection Vsub }
+"Taking the norm (magnitude) of a vector:"
+{ $subsection Vnorm }
+"Summing and taking the maximum of elements:"
+{ $subsection Vasum }
+{ $subsection Viamax }
+{ $subsection Vamax }
+"Scalar-vector products:"
+{ $subsection n*V! }
+{ $subsection n*V }
+{ $subsection V*n }
+{ $subsection V/n }
+{ $subsection Vneg }
+"Vector addition:"
+{ $subsection n*V+V! }
+{ $subsection n*V+V }
+{ $subsection V+ }
+{ $subsection V- }
+"Vector inner products:"
+{ $subsection V. }
+{ $subsection V.conj } ;
+
+ABOUT: "math.blas.vectors"
+
+HELP: blas-vector-base
+{ $class-description "The base class for all BLAS vector types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:"
+{ $list
+ { { $link float-blas-vector } }
+ { { $link double-blas-vector } }
+ { { $link float-complex-blas-vector } }
+ { { $link double-complex-blas-vector } }
+}
+"All of these subclasses share the same tuple layout:"
+{ $list
+ { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
+ { { $snippet "length" } " indicates the length of the vector;" }
+ { "and " { $snippet "inc" } " indicates the distance, in elements, between elements." }
+} } ;
+
+HELP: float-blas-vector
+{ $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: double-blas-vector
+{ $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: float-complex-blas-vector
+{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: double-complex-blas-vector
+{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+
+HELP: n*V+V!
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } }
+{ $description "Calculate the vector sum " { $snippet "αx + y" } " and replace the existing contents of y with the result. Corresponds to the xAXPY routines in BLAS." }
+{ $side-effects "y" } ;
+
+HELP: n*V!
+{ $values { "alpha" number } { "x" blas-vector-base } { "x=alpha*x" blas-vector-base } }
+{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and replace the existing contents of x with the result. Corresponds to the xSCAL routines in BLAS." }
+{ $side-effects "x" } ;
+
+HELP: V.
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x.y" number } }
+{ $description "Calculate the inner product " { $snippet "x⋅y" } ". Corresponds to the xDOT and xDOTU routines in BLAS." } ;
+
+HELP: V.conj
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "xconj.y" number } }
+{ $description "Calculate the conjugate inner product " { $snippet "x̅⋅y" } ". Corresponds to the xDOTC routines in BLAS." } ;
+
+HELP: Vnorm
+{ $values { "x" blas-vector-base } { "norm" number } }
+{ $description "Calculate the norm-2, i.e., the magnitude or absolute value, of " { $snippet "x" } " (" { $snippet "‖x‖₂" } "). Corresponds to the xNRM2 routines in BLAS." } ;
+
+HELP: Vasum
+{ $values { "x" blas-vector-base } { "sum" number } }
+{ $description "Calculate the sum of the norm-1s of the elements of " { $snippet "x" } " (" { $snippet "Σ ‖xᵢ‖₁" } "). Corresponds to the xASUM routines in BLAS." } ;
+
+HELP: Vswap
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x=y" blas-vector-base } { "y=x" blas-vector-base } }
+{ $description "Swap the contents of " { $snippet "x" } " and " { $snippet "y" } " in place. Corresponds to the xSWAP routines in BLAS." }
+{ $side-effects "x" "y" } ;
+
+HELP: Viamax
+{ $values { "x" blas-vector-base } { "max-i" integer } }
+{ $description "Return the index of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the smallest index. Corresponds to the IxAMAX routines in BLAS." } ;
+
+HELP: Vamax
+{ $values { "x" blas-vector-base } { "max" number } }
+{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the first element. Corresponds to the IxAMAX routines in BLAS." } ;
+
+{ Viamax Vamax } related-words
+
+HELP: <zero-vector>
+{ $values { "exemplar" blas-vector-base } { "zero" blas-vector-base } }
+{ $description "Return a vector of zeros with the same length and element type as " { $snippet "v" } ". The vector is constructed with an " { $snippet "inc" } " of zero, so it is not suitable for receiving results from BLAS functions; it is intended to be used as a term in other vector calculations. To construct an empty vector that can be used to receive results, see " { $link <empty-vector> } "." } ;
+
+HELP: n*V+V
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x+y" blas-vector-base } }
+{ $description "Calculate the vector sum " { $snippet "αx + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
+
+HELP: n*V
+{ $values { "alpha" "a number" } { "x" blas-vector-base } { "alpha*x" blas-vector-base } }
+{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
+
+HELP: V+
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x+y" blas-vector-base } }
+{ $description "Calculate the vector sum " { $snippet "x + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
+
+HELP: V-
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x-y" blas-vector-base } }
+{ $description "Calculate the vector difference " { $snippet "x – y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
+
+HELP: Vneg
+{ $values { "x" blas-vector-base } { "-x" blas-vector-base } }
+{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result." } ;
+
+HELP: V*n
+{ $values { "x" blas-vector-base } { "alpha" number } { "x*alpha" blas-vector-base } }
+{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
+
+HELP: V/n
+{ $values { "x" blas-vector-base } { "alpha" number } { "x/alpha" blas-vector-base } }
+{ $description "Calculate the scalar-vector product " { $snippet "(1/α)x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
+
+{ n*V+V! n*V! n*V+V n*V V+ V- Vneg V*n V/n } related-words
+
+HELP: Vsub
+{ $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } }
+{ $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ;
--- /dev/null
+USING: kernel math.blas.vectors math.blas.syntax sequences tools.test ;
+IN: math.blas.vectors.tests
+
+! clone
+
+[ svector{ 1.0 2.0 3.0 } ] [ svector{ 1.0 2.0 3.0 } clone ] unit-test
+[ f ] [ svector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test
+[ dvector{ 1.0 2.0 3.0 } ] [ dvector{ 1.0 2.0 3.0 } clone ] unit-test
+[ f ] [ dvector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test
+[ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test
+[ f ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test
+[ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test
+[ f ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test
+
+! nth
+
+[ 1.0 ] [ 2 svector{ 3.0 2.0 1.0 } nth ] unit-test
+[ 1.0 ] [ 2 dvector{ 3.0 2.0 1.0 } nth ] unit-test
+
+[ C{ 1.0 2.0 } ]
+[ 2 cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test
+
+[ C{ 1.0 2.0 } ]
+[ 2 zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test
+
+! set-nth
+
+[ svector{ 3.0 2.0 0.0 } ] [ 0.0 2 svector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test
+[ dvector{ 3.0 2.0 0.0 } ] [ 0.0 2 dvector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test
+
+[ cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [
+ C{ 3.0 4.0 } 2
+ cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } }
+ [ set-nth ] keep
+] unit-test
+[ zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [
+ C{ 3.0 4.0 } 2
+ zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } }
+ [ set-nth ] keep
+] unit-test
+
+! V+
+
+[ svector{ 11.0 22.0 } ] [ svector{ 1.0 2.0 } svector{ 10.0 20.0 } V+ ] unit-test
+[ dvector{ 11.0 22.0 } ] [ dvector{ 1.0 2.0 } dvector{ 10.0 20.0 } V+ ] unit-test
+
+[ cvector{ 11.0 C{ 22.0 33.0 } } ]
+[ cvector{ 1.0 C{ 2.0 3.0 } } cvector{ 10.0 C{ 20.0 30.0 } } V+ ]
+unit-test
+
+[ zvector{ 11.0 C{ 22.0 33.0 } } ]
+[ zvector{ 1.0 C{ 2.0 3.0 } } zvector{ 10.0 C{ 20.0 30.0 } } V+ ]
+unit-test
+
+! V-
+
+[ svector{ 9.0 18.0 } ] [ svector{ 10.0 20.0 } svector{ 1.0 2.0 } V- ] unit-test
+[ dvector{ 9.0 18.0 } ] [ dvector{ 10.0 20.0 } dvector{ 1.0 2.0 } V- ] unit-test
+
+[ cvector{ 9.0 C{ 18.0 27.0 } } ]
+[ cvector{ 10.0 C{ 20.0 30.0 } } cvector{ 1.0 C{ 2.0 3.0 } } V- ]
+unit-test
+
+[ zvector{ 9.0 C{ 18.0 27.0 } } ]
+[ zvector{ 10.0 C{ 20.0 30.0 } } zvector{ 1.0 C{ 2.0 3.0 } } V- ]
+unit-test
+
+! Vneg
+
+[ svector{ 1.0 -2.0 } ] [ svector{ -1.0 2.0 } Vneg ] unit-test
+[ dvector{ 1.0 -2.0 } ] [ dvector{ -1.0 2.0 } Vneg ] unit-test
+
+[ cvector{ 1.0 C{ -2.0 3.0 } } ] [ cvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test
+[ zvector{ 1.0 C{ -2.0 3.0 } } ] [ zvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test
+
+! n*V
+
+[ svector{ 100.0 200.0 } ] [ 10.0 svector{ 10.0 20.0 } n*V ] unit-test
+[ dvector{ 100.0 200.0 } ] [ 10.0 dvector{ 10.0 20.0 } n*V ] unit-test
+
+[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ C{ 10.0 2.0 } cvector{ 2.0 C{ 1.0 1.0 } } n*V ]
+unit-test
+
+[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ C{ 10.0 2.0 } zvector{ 2.0 C{ 1.0 1.0 } } n*V ]
+unit-test
+
+! V*n
+
+[ svector{ 100.0 200.0 } ] [ svector{ 10.0 20.0 } 10.0 V*n ] unit-test
+[ dvector{ 100.0 200.0 } ] [ dvector{ 10.0 20.0 } 10.0 V*n ] unit-test
+
+[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ cvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ]
+unit-test
+
+[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ zvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ]
+unit-test
+
+! V/n
+
+[ svector{ 1.0 2.0 } ] [ svector{ 4.0 8.0 } 4.0 V/n ] unit-test
+[ dvector{ 1.0 2.0 } ] [ dvector{ 4.0 8.0 } 4.0 V/n ] unit-test
+
+[ cvector{ C{ 0.0 -4.0 } 1.0 } ]
+[ cvector{ C{ 4.0 -4.0 } C{ 1.0 1.0 } } C{ 1.0 1.0 } V/n ]
+unit-test
+
+[ zvector{ C{ 0.0 -4.0 } 1.0 } ]
+[ zvector{ C{ 4.0 -4.0 } C{ 1.0 1.0 } } C{ 1.0 1.0 } V/n ]
+unit-test
+
+! V.
+
+[ 7.0 ] [ svector{ 1.0 2.5 } svector{ 2.0 2.0 } V. ] unit-test
+[ 7.0 ] [ dvector{ 1.0 2.5 } dvector{ 2.0 2.0 } V. ] unit-test
+[ C{ 7.0 7.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test
+[ C{ 7.0 7.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test
+
+! V.conj
+
+[ C{ 7.0 3.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test
+[ C{ 7.0 3.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test
+
+! Vnorm
+
+[ 5.0 ] [ svector{ 3.0 4.0 } Vnorm ] unit-test
+[ 5.0 ] [ dvector{ 3.0 4.0 } Vnorm ] unit-test
+
+[ 13.0 ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test
+[ 13.0 ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test
+
+! Vasum
+
+[ 6.0 ] [ svector{ 1.0 2.0 -3.0 } Vasum ] unit-test
+[ 6.0 ] [ dvector{ 1.0 2.0 -3.0 } Vasum ] unit-test
+
+[ 15.0 ] [ cvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test
+[ 15.0 ] [ zvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test
+
+! Vswap
+
+[ svector{ 2.0 2.0 } svector{ 1.0 1.0 } ]
+[ svector{ 1.0 1.0 } svector{ 2.0 2.0 } Vswap ]
+unit-test
+
+[ dvector{ 2.0 2.0 } dvector{ 1.0 1.0 } ]
+[ dvector{ 1.0 1.0 } dvector{ 2.0 2.0 } Vswap ]
+unit-test
+
+[ cvector{ 2.0 C{ 2.0 2.0 } } cvector{ C{ 1.0 1.0 } 1.0 } ]
+[ cvector{ C{ 1.0 1.0 } 1.0 } cvector{ 2.0 C{ 2.0 2.0 } } Vswap ]
+unit-test
+
+[ zvector{ 2.0 C{ 2.0 2.0 } } zvector{ C{ 1.0 1.0 } 1.0 } ]
+[ zvector{ C{ 1.0 1.0 } 1.0 } zvector{ 2.0 C{ 2.0 2.0 } } Vswap ]
+unit-test
+
+! Viamax
+
+[ 3 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test
+[ 3 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test
+[ 0 ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test
+[ 0 ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test
+
+! Vamax
+
+[ -6.0 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test
+[ -6.0 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test
+[ C{ 2.0 -5.0 } ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test
+[ C{ 2.0 -5.0 } ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test
+
+! Vsub
+
+[ svector{ -5.0 4.0 -6.0 } ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test
+[ dvector{ -5.0 4.0 -6.0 } ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test
+[ cvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ cvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test
+[ zvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ zvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test
--- /dev/null
+USING: accessors alien alien.c-types arrays byte-arrays combinators
+combinators.short-circuit fry kernel macros math math.blas.cblas
+math.complex math.functions math.order multi-methods qualified
+sequences sequences.private generalizations
+specialized-arrays.float specialized-arrays.double
+specialized-arrays.direct.float specialized-arrays.direct.double ;
+QUALIFIED: syntax
+IN: math.blas.vectors
+
+TUPLE: blas-vector-base data length inc ;
+TUPLE: float-blas-vector < blas-vector-base ;
+TUPLE: double-blas-vector < blas-vector-base ;
+TUPLE: float-complex-blas-vector < blas-vector-base ;
+TUPLE: double-complex-blas-vector < blas-vector-base ;
+
+INSTANCE: float-blas-vector sequence
+INSTANCE: double-blas-vector sequence
+INSTANCE: float-complex-blas-vector sequence
+INSTANCE: double-complex-blas-vector sequence
+
+C: <float-blas-vector> float-blas-vector
+C: <double-blas-vector> double-blas-vector
+C: <float-complex-blas-vector> float-complex-blas-vector
+C: <double-complex-blas-vector> double-complex-blas-vector
+
+GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y )
+GENERIC: n*V! ( alpha x -- x=alpha*x )
+
+GENERIC: V. ( x y -- x.y )
+GENERIC: V.conj ( x y -- xconj.y )
+GENERIC: Vnorm ( x -- norm )
+GENERIC: Vasum ( x -- sum )
+GENERIC: Vswap ( x y -- x=y y=x )
+
+GENERIC: Viamax ( x -- max-i )
+
+GENERIC: element-type ( v -- type )
+
+METHOD: element-type { float-blas-vector }
+ drop "float" ;
+METHOD: element-type { double-blas-vector }
+ drop "double" ;
+METHOD: element-type { float-complex-blas-vector }
+ drop "CBLAS_C" ;
+METHOD: element-type { double-complex-blas-vector }
+ drop "CBLAS_Z" ;
+
+<PRIVATE
+
+GENERIC: (blas-vector-like) ( data length inc exemplar -- vector )
+
+METHOD: (blas-vector-like) { object object object float-blas-vector }
+ drop <float-blas-vector> ;
+METHOD: (blas-vector-like) { object object object double-blas-vector }
+ drop <double-blas-vector> ;
+METHOD: (blas-vector-like) { object object object float-complex-blas-vector }
+ drop <float-complex-blas-vector> ;
+METHOD: (blas-vector-like) { object object object double-complex-blas-vector }
+ drop <double-complex-blas-vector> ;
+
+: (prepare-copy) ( v element-size -- length v-data v-inc v-dest-data v-dest-inc )
+ [ [ length>> ] [ data>> ] [ inc>> ] tri ] dip
+ 4 npick * <byte-array>
+ 1 ;
+
+MACRO: (do-copy) ( copy make-vector -- )
+ '[ over 6 npick _ 2dip 1 @ ] ;
+
+: (prepare-swap) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc v1 v2 )
+ [
+ [ [ length>> ] bi@ min ]
+ [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
+ ] 2keep ;
+
+: (prepare-axpy) ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc v2 )
+ [
+ [ [ length>> ] bi@ min swap ]
+ [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
+ ] keep ;
+
+: (prepare-scal) ( n v -- length n v-data v-inc v )
+ [ [ length>> swap ] [ data>> ] [ inc>> ] tri ] keep ;
+
+: (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc )
+ [ [ length>> ] bi@ min ]
+ [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi ;
+
+: (prepare-nrm2) ( v -- length v1-data v1-inc )
+ [ length>> ] [ data>> ] [ inc>> ] tri ;
+
+: (flatten-complex-sequence) ( seq -- seq' )
+ [ [ real-part ] [ imaginary-part ] bi 2array ] map concat ;
+
+: (>c-complex) ( complex -- alien )
+ [ real-part ] [ imaginary-part ] bi float-array{ } 2sequence underlying>> ;
+: (>z-complex) ( complex -- alien )
+ [ real-part ] [ imaginary-part ] bi double-array{ } 2sequence underlying>> ;
+
+: (c-complex>) ( alien -- complex )
+ 2 <direct-float-array> first2 rect> ;
+: (z-complex>) ( alien -- complex )
+ 2 <direct-double-array> first2 rect> ;
+
+: (prepare-nth) ( n v -- n*inc v-data )
+ [ inc>> ] [ data>> ] bi [ * ] dip ;
+
+MACRO: (complex-nth) ( nth-quot -- )
+ '[
+ [ 2 * dup 1+ ] dip
+ _ curry bi@ rect>
+ ] ;
+
+: (c-complex-nth) ( n alien -- complex )
+ [ float-nth ] (complex-nth) ;
+: (z-complex-nth) ( n alien -- complex )
+ [ double-nth ] (complex-nth) ;
+
+MACRO: (set-complex-nth) ( set-nth-quot -- )
+ '[
+ [
+ [ [ real-part ] [ imaginary-part ] bi ]
+ [ 2 * dup 1+ ] bi*
+ swapd
+ ] dip
+ _ curry 2bi@
+ ] ;
+
+: (set-c-complex-nth) ( complex n alien -- )
+ [ set-float-nth ] (set-complex-nth) ;
+: (set-z-complex-nth) ( complex n alien -- )
+ [ set-double-nth ] (set-complex-nth) ;
+
+PRIVATE>
+
+: <zero-vector> ( exemplar -- zero )
+ [ element-type <c-object> ]
+ [ length>> 0 ]
+ [ (blas-vector-like) ] tri ;
+
+: <empty-vector> ( length exemplar -- vector )
+ [ element-type <c-array> ]
+ [ 1 swap ] 2bi
+ (blas-vector-like) ;
+
+syntax:M: blas-vector-base length
+ length>> ;
+
+syntax:M: float-blas-vector nth-unsafe
+ (prepare-nth) float-nth ;
+syntax:M: float-blas-vector set-nth-unsafe
+ (prepare-nth) set-float-nth ;
+
+syntax:M: double-blas-vector nth-unsafe
+ (prepare-nth) double-nth ;
+syntax:M: double-blas-vector set-nth-unsafe
+ (prepare-nth) set-double-nth ;
+
+syntax:M: float-complex-blas-vector nth-unsafe
+ (prepare-nth) (c-complex-nth) ;
+syntax:M: float-complex-blas-vector set-nth-unsafe
+ (prepare-nth) (set-c-complex-nth) ;
+
+syntax:M: double-complex-blas-vector nth-unsafe
+ (prepare-nth) (z-complex-nth) ;
+syntax:M: double-complex-blas-vector set-nth-unsafe
+ (prepare-nth) (set-z-complex-nth) ;
+
+syntax:M: blas-vector-base equal?
+ {
+ [ [ length ] bi@ = ]
+ [ [ = ] 2all? ]
+ } 2&& ;
+
+: >float-blas-vector ( seq -- v )
+ [ >float-array underlying>> ] [ length ] bi 1 <float-blas-vector> ;
+: >double-blas-vector ( seq -- v )
+ [ >double-array underlying>> ] [ length ] bi 1 <double-blas-vector> ;
+: >float-complex-blas-vector ( seq -- v )
+ [ (flatten-complex-sequence) >float-array underlying>> ] [ length ] bi
+ 1 <float-complex-blas-vector> ;
+: >double-complex-blas-vector ( seq -- v )
+ [ (flatten-complex-sequence) >double-array underlying>> ] [ length ] bi
+ 1 <double-complex-blas-vector> ;
+
+syntax:M: float-blas-vector clone
+ "float" heap-size (prepare-copy)
+ [ cblas_scopy ] [ <float-blas-vector> ] (do-copy) ;
+syntax:M: double-blas-vector clone
+ "double" heap-size (prepare-copy)
+ [ cblas_dcopy ] [ <double-blas-vector> ] (do-copy) ;
+syntax:M: float-complex-blas-vector clone
+ "CBLAS_C" heap-size (prepare-copy)
+ [ cblas_ccopy ] [ <float-complex-blas-vector> ] (do-copy) ;
+syntax:M: double-complex-blas-vector clone
+ "CBLAS_Z" heap-size (prepare-copy)
+ [ cblas_zcopy ] [ <double-complex-blas-vector> ] (do-copy) ;
+
+METHOD: Vswap { float-blas-vector float-blas-vector }
+ (prepare-swap) [ cblas_sswap ] 2dip ;
+METHOD: Vswap { double-blas-vector double-blas-vector }
+ (prepare-swap) [ cblas_dswap ] 2dip ;
+METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector }
+ (prepare-swap) [ cblas_cswap ] 2dip ;
+METHOD: Vswap { double-complex-blas-vector double-complex-blas-vector }
+ (prepare-swap) [ cblas_zswap ] 2dip ;
+
+METHOD: n*V+V! { real float-blas-vector float-blas-vector }
+ (prepare-axpy) [ cblas_saxpy ] dip ;
+METHOD: n*V+V! { real double-blas-vector double-blas-vector }
+ (prepare-axpy) [ cblas_daxpy ] dip ;
+METHOD: n*V+V! { number float-complex-blas-vector float-complex-blas-vector }
+ [ (>c-complex) ] 2dip
+ (prepare-axpy) [ cblas_caxpy ] dip ;
+METHOD: n*V+V! { number double-complex-blas-vector double-complex-blas-vector }
+ [ (>z-complex) ] 2dip
+ (prepare-axpy) [ cblas_zaxpy ] dip ;
+
+METHOD: n*V! { real float-blas-vector }
+ (prepare-scal) [ cblas_sscal ] dip ;
+METHOD: n*V! { real double-blas-vector }
+ (prepare-scal) [ cblas_dscal ] dip ;
+METHOD: n*V! { number float-complex-blas-vector }
+ [ (>c-complex) ] dip
+ (prepare-scal) [ cblas_cscal ] dip ;
+METHOD: n*V! { number double-complex-blas-vector }
+ [ (>z-complex) ] dip
+ (prepare-scal) [ cblas_zscal ] dip ;
+
+: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
+: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
+
+: V+ ( x y -- x+y )
+ 1.0 -rot n*V+V ; inline
+: V- ( x y -- x-y )
+ -1.0 spin n*V+V ; inline
+
+: Vneg ( x -- -x )
+ -1.0 swap n*V ; inline
+
+: V*n ( x alpha -- x*alpha )
+ swap n*V ; inline
+: V/n ( x alpha -- x/alpha )
+ recip swap n*V ; inline
+
+METHOD: V. { float-blas-vector float-blas-vector }
+ (prepare-dot) cblas_sdot ;
+METHOD: V. { double-blas-vector double-blas-vector }
+ (prepare-dot) cblas_ddot ;
+METHOD: V. { float-complex-blas-vector float-complex-blas-vector }
+ (prepare-dot)
+ "CBLAS_C" <c-object> [ cblas_cdotu_sub ] keep (c-complex>) ;
+METHOD: V. { double-complex-blas-vector double-complex-blas-vector }
+ (prepare-dot)
+ "CBLAS_Z" <c-object> [ cblas_zdotu_sub ] keep (z-complex>) ;
+
+METHOD: V.conj { float-blas-vector float-blas-vector }
+ (prepare-dot) cblas_sdot ;
+METHOD: V.conj { double-blas-vector double-blas-vector }
+ (prepare-dot) cblas_ddot ;
+METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector }
+ (prepare-dot)
+ "CBLAS_C" <c-object> [ cblas_cdotc_sub ] keep (c-complex>) ;
+METHOD: V.conj { double-complex-blas-vector double-complex-blas-vector }
+ (prepare-dot)
+ "CBLAS_Z" <c-object> [ cblas_zdotc_sub ] keep (z-complex>) ;
+
+METHOD: Vnorm { float-blas-vector }
+ (prepare-nrm2) cblas_snrm2 ;
+METHOD: Vnorm { double-blas-vector }
+ (prepare-nrm2) cblas_dnrm2 ;
+METHOD: Vnorm { float-complex-blas-vector }
+ (prepare-nrm2) cblas_scnrm2 ;
+METHOD: Vnorm { double-complex-blas-vector }
+ (prepare-nrm2) cblas_dznrm2 ;
+
+METHOD: Vasum { float-blas-vector }
+ (prepare-nrm2) cblas_sasum ;
+METHOD: Vasum { double-blas-vector }
+ (prepare-nrm2) cblas_dasum ;
+METHOD: Vasum { float-complex-blas-vector }
+ (prepare-nrm2) cblas_scasum ;
+METHOD: Vasum { double-complex-blas-vector }
+ (prepare-nrm2) cblas_dzasum ;
+
+METHOD: Viamax { float-blas-vector }
+ (prepare-nrm2) cblas_isamax ;
+METHOD: Viamax { double-blas-vector }
+ (prepare-nrm2) cblas_idamax ;
+METHOD: Viamax { float-complex-blas-vector }
+ (prepare-nrm2) cblas_icamax ;
+METHOD: Viamax { double-complex-blas-vector }
+ (prepare-nrm2) cblas_izamax ;
+
+: Vamax ( x -- max )
+ [ Viamax ] keep nth ; inline
+
+: Vsub ( v start length -- sub )
+ rot [
+ [
+ nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri
+ [ * * ] dip <displaced-alien>
+ ] [ swap 2nip ] [ 2nip inc>> ] 3tri
+ ] keep (blas-vector-like) ;
--- /dev/null
+Slava Pestov
+Doug Coleman
+Aaron Schaefer
--- /dev/null
+USING: help.markup help.syntax kernel math math.order sequences ;
+IN: math.combinatorics
+
+HELP: factorial
+{ $values { "n" "a non-negative integer" } { "n!" integer } }
+{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ;
+
+HELP: nPk
+{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
+{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ;
+
+HELP: nCk
+{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
+{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ;
+
+HELP: permutation
+{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
+{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
+{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ;
+
+HELP: all-permutations
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
+
+HELP: inverse-permutation
+{ $values { "seq" sequence } { "permutation" sequence } }
+{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
+{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
+
+
+IN: math.combinatorics.private
+
+HELP: factoradic
+{ $values { "n" integer } { "factoradic" sequence } }
+{ $description "Converts a positive integer " { $snippet "n" } " to factoradic form. The factoradic of an integer is its representation based on a mixed radix numerical system that corresponds to the values of " { $snippet "n" } " factorial." }
+{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ;
+
+HELP: >permutation
+{ $values { "factoradic" sequence } { "permutation" sequence } }
+{ $description "Converts an integer represented in factoradic form into its corresponding unique permutation (0-based)." }
+{ $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } }
+{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ;
+
--- /dev/null
+USING: math.combinatorics math.combinatorics.private tools.test ;
+IN: math.combinatorics.tests
+
+[ { } ] [ 0 factoradic ] unit-test
+[ { 1 0 } ] [ 1 factoradic ] unit-test
+[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
+
+[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
+[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
+[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
+
+[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
+[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
+[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
+
+[ 1 ] [ 0 factorial ] unit-test
+[ 1 ] [ 1 factorial ] unit-test
+[ 3628800 ] [ 10 factorial ] unit-test
+
+[ 1 ] [ 3 0 nPk ] unit-test
+[ 6 ] [ 3 2 nPk ] unit-test
+[ 6 ] [ 3 3 nPk ] unit-test
+[ 0 ] [ 3 4 nPk ] unit-test
+[ 311875200 ] [ 52 5 nPk ] unit-test
+[ 672151459757865654763838640470031391460745878674027315200000000000 ] [ 52 47 nPk ] unit-test
+
+[ 1 ] [ 3 0 nCk ] unit-test
+[ 3 ] [ 3 2 nCk ] unit-test
+[ 1 ] [ 3 3 nCk ] unit-test
+[ 0 ] [ 3 4 nCk ] unit-test
+[ 2598960 ] [ 52 5 nCk ] unit-test
+[ 2598960 ] [ 52 47 nCk ] unit-test
+
+[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
+[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
+[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test
+
+[ { { "a" "b" "c" } { "a" "c" "b" }
+ { "b" "a" "c" } { "b" "c" "a" }
+ { "c" "a" "b" } { "c" "b" "a" } } ] [ { "a" "b" "c" } all-permutations ] unit-test
+
+[ { 0 1 2 } ] [ { "a" "b" "c" } inverse-permutation ] unit-test
+[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
+[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test
+
--- /dev/null
+! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel math math.order math.ranges mirrors
+namespaces sequences sorting fry ;
+IN: math.combinatorics
+
+<PRIVATE
+
+: possible? ( n m -- ? )
+ 0 rot between? ; inline
+
+: twiddle ( n k -- n k )
+ 2dup - dupd > [ dupd - ] when ; inline
+
+! See this article for explanation of the factoradic-based permutation methodology:
+! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
+
+: factoradic ( n -- factoradic )
+ 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
+
+: (>permutation) ( seq n -- seq )
+ [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
+
+: >permutation ( factoradic -- permutation )
+ reverse 1 cut [ (>permutation) ] each ;
+
+: permutation-indices ( n seq -- permutation )
+ length [ factoradic ] dip 0 pad-left >permutation ;
+
+PRIVATE>
+
+: factorial ( n -- n! )
+ 1 [ 1+ * ] reduce ;
+
+: nPk ( n k -- nPk )
+ 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
+
+: nCk ( n k -- nCk )
+ twiddle [ nPk ] keep factorial / ;
+
+: permutation ( n seq -- seq )
+ [ permutation-indices ] keep nths ;
+
+: all-permutations ( seq -- seq )
+ [ length factorial ] keep '[ _ permutation ] map ;
+
+: each-permutation ( seq quot -- )
+ [ [ length factorial ] keep ] dip
+ '[ _ permutation @ ] each ; inline
+
+: reduce-permutations ( seq initial quot -- result )
+ swapd each-permutation ; inline
+
+: inverse-permutation ( seq -- permutation )
+ <enum> >alist sort-values keys ;
--- /dev/null
+Permutations and combinations
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax math sequences ;
+IN: math.polynomials
+
+ARTICLE: "polynomials" "Polynomials"
+"A polynomial is a vector with the highest powers on the right:"
+{ $code "{ 1 1 0 1 } -> 1 + x + x^3" "{ } -> 0" }
+"Numerous words are defined to help with polynomial arithmetic:"
+{ $subsection p= }
+{ $subsection p+ }
+{ $subsection p- }
+{ $subsection p* }
+{ $subsection p-sq }
+{ $subsection powers }
+{ $subsection n*p }
+{ $subsection p/mod }
+{ $subsection pgcd }
+{ $subsection polyval }
+{ $subsection pdiff }
+{ $subsection pextend-conv }
+{ $subsection ptrim }
+{ $subsection 2ptrim } ;
+
+ABOUT: "polynomials"
+
+HELP: powers
+{ $values { "n" integer } { "x" number } { "seq" sequence } }
+{ $description "Output a sequence having " { $snippet "n" } " elements in the format: " { $snippet "{ 1 x x^2 x^3 ... }" } "." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "4 2 powers ." "{ 1 2 4 8 }" } } ;
+
+HELP: p=
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "?" "a boolean" } }
+{ $description "Tests if two polynomials are equal." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 } { 0 1 0 } p= ." "t" } } ;
+
+HELP: ptrim
+{ $values { "p" "a polynomial" } { "p" "a polynomial" } }
+{ $description "Trims excess zeros from a polynomial." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 0 0 } ptrim ." "{ 0 1 }" } } ;
+
+HELP: 2ptrim
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
+{ $description "Trims excess zeros from two polynomials." }
+{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim [ . ] bi@" "{ 0 1 }\n{ 1 }" } } ;
+
+HELP: p+
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
+{ $description "Adds " { $snippet "p" } " and " { $snippet "q" } " component-wise." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } p+ ." "{ 1 1 1 }" } } ;
+
+HELP: p-
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
+{ $description "Subtracts " { $snippet "q" } " from " { $snippet "p" } " component-wise." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 } { 0 1 } p- ." "{ 1 0 1 }" } } ;
+
+HELP: n*p
+{ $values { "n" number } { "p" "a polynomial" } { "n*p" "a polynomial" } }
+{ $description "Multiplies each element of " { $snippet "p" } " by " { $snippet "n" } "." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "4 { 3 0 1 } n*p ." "{ 12 0 4 }" } } ;
+
+HELP: pextend-conv
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
+{ $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." }
+{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ;
+
+HELP: p*
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
+{ $description "Multiplies two polynomials." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 3 0 0 0 } { 1 2 0 0 } p* ." "{ 1 4 7 6 0 0 0 0 0 }" } } ;
+
+HELP: p-sq
+{ $values { "p" "a polynomial" } { "p^2" "a polynomial" } }
+{ $description "Squares a polynomial." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 0 } p-sq ." "{ 1 4 4 0 0 }" } } ;
+
+HELP: p/mod
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } }
+{ $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." }
+{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 1 1 1 } { 3 1 } p/mod [ . ] bi@" "V{ 7 -2 1 }\nV{ -20 0 0 }" } } ;
+
+HELP: pgcd
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "a" "a polynomial" } { "d" "a polynomial" } }
+{ $description "Computes the greatest common divisor " { $snippet "d" } " of " { $snippet "p" } " and " { $snippet "q" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*q = d mod p" } }
+{ $notes "GCD in the case of polynomials is a monic polynomial of the highest possible degree that divides into both " { $snippet "p" } " and " { $snippet "q" } "." }
+{ $examples
+ { $example "USING: kernel math.polynomials prettyprint ;"
+ "{ 1 1 1 1 } { 1 1 } pgcd [ . ] bi@"
+ "{ 0 0 }\n{ 1 1 }"
+ }
+} ;
+
+HELP: pdiff
+{ $values { "p" "a polynomial" } { "p'" "a polynomial" } }
+{ $description "Finds the derivative of " { $snippet "p" } "." } ;
+
+HELP: polyval
+{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } }
+{ $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ;
+
--- /dev/null
+USING: kernel math math.polynomials tools.test ;
+IN: math.polynomials.tests
+
+[ { 0 1 } ] [ { 0 1 0 0 } ptrim ] unit-test
+[ { 1 } ] [ { 1 0 0 } ptrim ] unit-test
+[ { 0 } ] [ { 0 } ptrim ] unit-test
+[ { 3 10 8 } ] [ { 1 2 } { 3 4 } p* ] unit-test
+[ { 3 10 8 } ] [ { 3 4 } { 1 2 } p* ] unit-test
+[ { 0 0 0 0 0 0 0 0 0 0 } ] [ { 0 0 0 } { 0 0 0 0 0 0 0 0 } p* ] unit-test
+[ { 0 1 } ] [ { 0 1 } { 1 } p* ] unit-test
+[ { 0 } ] [ { } { } p* ] unit-test
+[ { 0 } ] [ { 0 } { } p* ] unit-test
+[ { 0 } ] [ { } { 0 } p* ] unit-test
+[ { 0 0 0 } ] [ { 0 0 0 } { 0 0 0 } p+ ] unit-test
+[ { 0 0 0 } ] [ { 0 0 0 } { 0 0 0 } p- ] unit-test
+[ { 0 0 0 } ] [ 4 { 0 0 0 } n*p ] unit-test
+[ { 4 8 0 12 } ] [ 4 { 1 2 0 3 } n*p ] unit-test
+[ { 1 4 7 6 0 0 0 0 0 } ] [ { 1 2 3 0 0 0 } { 1 2 0 0 } p* ] unit-test
+[ V{ 7 -2 1 } V{ -20 0 0 } ] [ { 1 1 1 1 } { 3 1 } p/mod ] unit-test
+[ V{ 0 0 } V{ 1 1 } ] [ { 1 1 } { 1 1 1 1 } p/mod ] unit-test
+[ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 } { 1 1 } p/mod ] unit-test
+[ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 } { 1 1 0 0 0 0 0 0 } p/mod ] unit-test
+[ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 0 0 0 0 } { 1 1 0 0 } p/mod ] unit-test
+[ V{ 5.0 } V{ 0 } ] [ { 10.0 } { 2.0 } p/mod ] unit-test
+[ V{ 15/16 } V{ 0 } ] [ { 3/4 } { 4/5 } p/mod ] unit-test
+[ t ] [ { 0 1 } { 0 1 0 } p= ] unit-test
+[ f ] [ { 0 0 1 } { 0 1 0 } p= ] unit-test
+[ t ] [ { 1 1 1 } { 1 1 1 } p= ] unit-test
+[ { 0 0 } { 1 1 } ] [ { 1 1 1 1 } { 1 1 } pgcd ] unit-test
+
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel make math math.order math.vectors sequences shuffle
+ splitting vectors ;
+IN: math.polynomials
+
+<PRIVATE
+
+: 2pad-left ( p q n -- p q ) [ 0 pad-left ] curry bi@ ;
+: 2pad-right ( p q n -- p q ) [ 0 pad-right ] curry bi@ ;
+: pextend ( p q -- p q ) 2dup [ length ] bi@ max 2pad-right ;
+: pextend-left ( p q -- p q ) 2dup [ length ] bi@ max 2pad-left ;
+: unempty ( seq -- seq ) [ { 0 } ] when-empty ;
+: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
+
+PRIVATE>
+
+: powers ( n x -- seq )
+ <array> 1 [ * ] accumulate nip ;
+
+: p= ( p q -- ? ) pextend = ;
+
+: ptrim ( p -- p )
+ dup length 1 = [ [ zero? ] trim-right ] unless ;
+
+: 2ptrim ( p q -- p q ) [ ptrim ] bi@ ;
+: p+ ( p q -- r ) pextend v+ ;
+: p- ( p q -- r ) pextend v- ;
+: n*p ( n p -- n*p ) n*v ;
+
+: pextend-conv ( p q -- p q )
+ 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
+
+: p* ( p q -- r )
+ 2unempty pextend-conv <reversed> dup length
+ [ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
+
+: p-sq ( p -- p^2 )
+ dup p* ;
+
+<PRIVATE
+
+: p/mod-setup ( p p -- p p n )
+ 2ptrim
+ 2dup [ length ] bi@ -
+ dup 1 < [ drop 1 ] when
+ [ over length + 0 pad-left pextend ] keep 1+ ;
+
+: /-last ( seq seq -- a )
+ #! divide the last two numbers in the sequences
+ [ peek ] bi@ / ;
+
+: (p/mod) ( p p -- p p )
+ 2dup /-last
+ 2dup , n*p swapd
+ p- >vector
+ dup pop* swap rest-slice ;
+
+PRIVATE>
+
+: p/mod ( p q -- z w )
+ p/mod-setup [ [ (p/mod) ] times ] V{ } make
+ reverse nip swap 2ptrim pextend ;
+
+<PRIVATE
+
+: (pgcd) ( b a y x -- a d )
+ dup V{ 0 } clone p= [
+ drop nip
+ ] [
+ tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
+ ] if ;
+
+PRIVATE>
+
+: pgcd ( p q -- a d )
+ swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ;
+
+: pdiff ( p -- p' )
+ dup length v* { 0 } ?head drop ;
+
+: polyval ( p x -- p[x] )
+ [ dup length ] dip powers v. ;
+
--- /dev/null
+Polynomial arithmetic
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax math math.vectors vectors ;
+IN: math.quaternions
+
+HELP: q*
+{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } }
+{ $description "Multiply quaternions." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q* ." "{ 0 C{ 0 1 } }" } } ;
+
+HELP: qconjugate
+{ $values { "u" "a quaternion" } { "u'" "a quaternion" } }
+{ $description "Quaternion conjugate." } ;
+
+HELP: qrecip
+{ $values { "u" "a quaternion" } { "1/u" "a quaternion" } }
+{ $description "Quaternion inverse." } ;
+
+HELP: q/
+{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u/v" "a quaternion" } }
+{ $description "Divide quaternions." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 C{ 0 1 } } { 0 1 } q/ ." "{ C{ 0 1 } 0 }" } } ;
+
+HELP: q*n
+{ $values { "q" "a quaternion" } { "n" number } { "q" "a quaternion" } }
+{ $description "Multiplies each element of " { $snippet "q" } " by " { $snippet "n" } "." }
+{ $notes "You will get the wrong result if you try to multiply a quaternion by a complex number on the right using " { $link v*n } ". Use this word instead."
+ $nl "Note that " { $link v*n } " with a quaternion and a real is okay." } ;
+
+HELP: c>q
+{ $values { "c" number } { "q" "a quaternion" } }
+{ $description "Turn a complex number into a quaternion." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "C{ 0 1 } c>q ." "{ C{ 0 1 } 0 }" } } ;
+
+HELP: v>q
+{ $values { "v" vector } { "q" "a quaternion" } }
+{ $description "Turn a 3-vector into a quaternion with real part 0." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 1 0 0 } v>q ." "{ C{ 0 1 } 0 }" } } ;
+
+HELP: q>v
+{ $values { "q" "a quaternion" } { "v" vector } }
+{ $description "Get the vector part of a quaternion, discarding the real part." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } q>v ." "{ 1 0 0 }" } } ;
+
+HELP: euler
+{ $values { "phi" number } { "theta" number } { "psi" number } { "q" "a quaternion" } }
+{ $description "Convert a rotation given by Euler angles (phi, theta, and psi) to a quaternion." } ;
+
--- /dev/null
+IN: math.quaternions.tests
+USING: tools.test math.quaternions kernel math.vectors
+math.constants ;
+
+[ 1.0 ] [ qi norm ] unit-test
+[ 1.0 ] [ qj norm ] unit-test
+[ 1.0 ] [ qk norm ] unit-test
+[ 1.0 ] [ q1 norm ] unit-test
+[ 0.0 ] [ q0 norm ] unit-test
+[ t ] [ qi qj q* qk = ] unit-test
+[ t ] [ qj qk q* qi = ] unit-test
+[ t ] [ qk qi q* qj = ] unit-test
+[ t ] [ qi qi q* q1 v+ q0 = ] unit-test
+[ t ] [ qj qj q* q1 v+ q0 = ] unit-test
+[ t ] [ qk qk q* q1 v+ q0 = ] unit-test
+[ t ] [ qi qj qk q* q* q1 v+ q0 = ] unit-test
+[ t ] [ C{ 0 1 } qj n*v qk = ] unit-test
+[ t ] [ qj C{ 0 1 } q*n qk v+ q0 = ] unit-test
+[ t ] [ qk qj q/ qi = ] unit-test
+[ t ] [ qi qk q/ qj = ] unit-test
+[ t ] [ qj qi q/ qk = ] unit-test
+[ t ] [ qi q>v v>q qi = ] unit-test
+[ t ] [ qj q>v v>q qj = ] unit-test
+[ t ] [ qk q>v v>q qk = ] unit-test
+[ t ] [ 1 c>q q1 = ] unit-test
+[ t ] [ C{ 0 1 } c>q qi = ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math math.functions math.vectors sequences ;
+IN: math.quaternions
+
+! Everybody's favorite non-commutative skew field, the quaternions!
+
+! Quaternions are represented as pairs of complex numbers, using the
+! identity: (a+bi)+(c+di)j = a+bi+cj+dk.
+
+<PRIVATE
+
+: ** conjugate * ; inline
+
+: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
+
+: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline
+
+: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline
+
+PRIVATE>
+
+: q* ( u v -- u*v )
+ [ q*a ] [ q*b ] 2bi 2array ;
+
+: qconjugate ( u -- u' )
+ first2 [ conjugate ] [ neg ] bi* 2array ;
+
+: qrecip ( u -- 1/u )
+ qconjugate dup norm-sq v/n ;
+
+: q/ ( u v -- u/v )
+ qrecip q* ;
+
+: q*n ( q n -- q )
+ conjugate v*n ;
+
+: c>q ( c -- q )
+ 0 2array ;
+
+: v>q ( v -- q )
+ first3 rect> [ 0 swap rect> ] dip 2array ;
+
+: q>v ( q -- v )
+ first2 [ imaginary-part ] dip >rect 3array ;
+
+! Zero
+: q0 { 0 0 } ;
+
+! Units
+: q1 { 1 0 } ;
+: qi { C{ 0 1 } 0 } ;
+: qj { 0 1 } ;
+: qk { 0 C{ 0 1 } } ;
+
+! Euler angles
+
+<PRIVATE
+
+: (euler) ( theta unit -- q )
+ [ -0.5 * [ cos c>q ] [ sin ] bi ] dip n*v v- ;
+
+PRIVATE>
+
+: euler ( phi theta psi -- q )
+ [ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ;
--- /dev/null
+Quaternion arithmetic and Euler angles
--- /dev/null
+Doug Coleman
+Michael Judge
--- /dev/null
+USING: help.markup help.syntax debugger ;
+IN: math.statistics
+
+HELP: geometric-mean
+{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
+{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
+{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
+
+HELP: harmonic-mean
+{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
+{ $notes "Positive reals only." }
+{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } }
+{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
+
+HELP: mean
+{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." }
+{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } }
+{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
+
+HELP: median
+{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." }
+{ $examples
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } median ." "2+1/2" } }
+{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
+
+HELP: range
+{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } range ." "3" } } ;
+
+HELP: std
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
+{ $description "Computes the standard deviation of " { $snippet "seq" } ", which is the square root of the variance. It measures how widely spread the values in a sequence are about the mean." }
+{ $examples
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;
+
+HELP: ste
+ { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
+ { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." }
+ { $examples
+ { $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" }
+ { $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ;
+
+HELP: var
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
+{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." }
+{ $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." }
+{ $examples
+ { $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } var ." "1" }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } var ." "1+2/3" } } ;
+
--- /dev/null
+USING: kernel math math.functions math.statistics tools.test ;
+IN: math.statistics.tests
+
+[ 1 ] [ { 1 } mean ] unit-test
+[ 3/2 ] [ { 1 2 } mean ] unit-test
+[ 0 ] [ { 0 0 0 } geometric-mean ] unit-test
+[ t ] [ { 2 2 2 2 } geometric-mean 2.0 .0001 ~ ] unit-test
+[ 1.0 ] [ { 1 1 1 } geometric-mean ] unit-test
+[ 1/3 ] [ { 1 1 1 } harmonic-mean ] unit-test
+
+[ 0 ] [ { 1 } range ] unit-test
+[ 89 ] [ { 1 2 30 90 } range ] unit-test
+[ 2 ] [ { 1 2 3 } median ] unit-test
+[ 5/2 ] [ { 1 2 3 4 } median ] unit-test
+
+[ 1 ] [ { 1 2 3 } var ] unit-test
+[ 1.0 ] [ { 1 2 3 } std ] unit-test
+[ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test
+
+[ t ] [ { 23.2 33.4 22.5 66.3 44.5 } std 18.1906 - .0001 < ] unit-test
+
+[ 0 ] [ { 1 } var ] unit-test
+[ 0.0 ] [ { 1 } std ] unit-test
+[ 0.0 ] [ { 1 } ste ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman, Michael Judge.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators kernel math math.analysis math.functions sequences
+ sequences.lib sorting ;
+IN: math.statistics
+
+: mean ( seq -- n )
+ [ sum ] [ length ] bi / ;
+
+: geometric-mean ( seq -- n )
+ [ length ] [ product ] bi nth-root ;
+
+: harmonic-mean ( seq -- n )
+ [ recip ] sigma recip ;
+
+: median ( seq -- n )
+ natural-sort dup length even? [
+ [ midpoint@ dup 1- 2array ] keep nths mean
+ ] [
+ [ midpoint@ ] keep nth
+ ] if ;
+
+: range ( seq -- n )
+ minmax swap - ;
+
+: var ( seq -- x )
+ #! normalize by N-1
+ dup length 1 <= [
+ drop 0
+ ] [
+ [ [ mean ] keep [ - sq ] with sigma ] keep
+ length 1- /
+ ] if ;
+
+: std ( seq -- x )
+ var sqrt ;
+
+: ste ( seq -- x )
+ [ std ] [ length ] bi sqrt / ;
+
+: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
+ ! finds sigma((xi-mean(x))(yi-mean(y))
+ 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
+
+: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
+ * recip [ [ ((r)) ] keep length 1- / ] dip * ;
+
+: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
+ first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
+
+: r ( {{x,y}...} -- r )
+ [r] (r) ;
+
+: r^2 ( {{x,y}...} -- r )
+ r sq ;
+
+: least-squares ( {{x,y}...} -- alpha beta )
+ [r] { [ 2dup ] [ ] [ ] [ ] [ ] } spread
+ ! stack is mean(x) mean(y) mean(x) mean(y) {x} {y} sx sy
+ [ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy
+ swap / * ! stack is mean(x) mean(y) beta
+ [ swapd * - ] keep ;
+
--- /dev/null
+Mean, median, standard deviation, and other statistical routines
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
{ $code
"! First alternative; uses dip"
- "[ [ 1 + ] dip 1 - dip ] 2 *"
+ "[ [ 1 + ] dip 1 - ] dip 2 *"
"! Second alternative: uses tri*"
"[ 1 + ] [ 1 - ] [ 2 * ] tri*"
}
"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers."
$nl
"Introducing a floating point number in a computation forces the result to be expressed in floating point."
-{ $example "5/4 1/2 + ." "7/4" }
+{ $example "5/4 1/2 + ." "1+3/4" }
{ $example "5/4 0.5 + ." "1.75" }
"Integers and rationals can be converted to floats:"
{ $subsection >float }
+++ /dev/null
-USING: alien alien.c-types alien.syntax kernel system combinators ;
-IN: math.blas.cblas
-
-<< "cblas" {
- { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
- { [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
- { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] }
- { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library ] }
- [ "libblas.so" "cdecl" add-library ]
-} cond >>
-
-LIBRARY: cblas
-
-TYPEDEF: int CBLAS_ORDER
-: CblasRowMajor 101 ; inline
-: CblasColMajor 102 ; inline
-
-TYPEDEF: int CBLAS_TRANSPOSE
-: CblasNoTrans 111 ; inline
-: CblasTrans 112 ; inline
-: CblasConjTrans 113 ; inline
-
-TYPEDEF: int CBLAS_UPLO
-: CblasUpper 121 ; inline
-: CblasLower 122 ; inline
-
-TYPEDEF: int CBLAS_DIAG
-: CblasNonUnit 131 ; inline
-: CblasUnit 132 ; inline
-
-TYPEDEF: int CBLAS_SIDE
-: CblasLeft 141 ; inline
-: CblasRight 142 ; inline
-
-TYPEDEF: int CBLAS_INDEX
-
-C-STRUCT: CBLAS_C
- { "float" "real" }
- { "float" "imag" } ;
-C-STRUCT: CBLAS_Z
- { "double" "real" }
- { "double" "imag" } ;
-
-! Level 1 BLAS (scalar-vector and vector-vector)
-
-FUNCTION: float cblas_sdsdot
- ( int N, float alpha, float* X, int incX, float* Y, int incY ) ;
-FUNCTION: double cblas_dsdot
- ( int N, float* X, int incX, float* Y, int incY ) ;
-FUNCTION: float cblas_sdot
- ( int N, float* X, int incX, float* Y, int incY ) ;
-FUNCTION: double cblas_ddot
- ( int N, double* X, int incX, double* Y, int incY ) ;
-
-FUNCTION: void cblas_cdotu_sub
- ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotu ) ;
-FUNCTION: void cblas_cdotc_sub
- ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotc ) ;
-
-FUNCTION: void cblas_zdotu_sub
- ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotu ) ;
-FUNCTION: void cblas_zdotc_sub
- ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotc ) ;
-
-FUNCTION: float cblas_snrm2
- ( int N, float* X, int incX ) ;
-FUNCTION: float cblas_sasum
- ( int N, float* X, int incX ) ;
-
-FUNCTION: double cblas_dnrm2
- ( int N, double* X, int incX ) ;
-FUNCTION: double cblas_dasum
- ( int N, double* X, int incX ) ;
-
-FUNCTION: float cblas_scnrm2
- ( int N, CBLAS_C* X, int incX ) ;
-FUNCTION: float cblas_scasum
- ( int N, CBLAS_C* X, int incX ) ;
-
-FUNCTION: double cblas_dznrm2
- ( int N, CBLAS_Z* X, int incX ) ;
-FUNCTION: double cblas_dzasum
- ( int N, CBLAS_Z* X, int incX ) ;
-
-FUNCTION: CBLAS_INDEX cblas_isamax
- ( int N, float* X, int incX ) ;
-FUNCTION: CBLAS_INDEX cblas_idamax
- ( int N, double* X, int incX ) ;
-FUNCTION: CBLAS_INDEX cblas_icamax
- ( int N, CBLAS_C* X, int incX ) ;
-FUNCTION: CBLAS_INDEX cblas_izamax
- ( int N, CBLAS_Z* X, int incX ) ;
-
-FUNCTION: void cblas_sswap
- ( int N, float* X, int incX, float* Y, int incY ) ;
-FUNCTION: void cblas_scopy
- ( int N, float* X, int incX, float* Y, int incY ) ;
-FUNCTION: void cblas_saxpy
- ( int N, float alpha, float* X, int incX, float* Y, int incY ) ;
-
-FUNCTION: void cblas_dswap
- ( int N, double* X, int incX, double* Y, int incY ) ;
-FUNCTION: void cblas_dcopy
- ( int N, double* X, int incX, double* Y, int incY ) ;
-FUNCTION: void cblas_daxpy
- ( int N, double alpha, double* X, int incX, double* Y, int incY ) ;
-
-FUNCTION: void cblas_cswap
- ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
-FUNCTION: void cblas_ccopy
- ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
-FUNCTION: void cblas_caxpy
- ( int N, CBLAS_C* alpha, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
-
-FUNCTION: void cblas_zswap
- ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
-FUNCTION: void cblas_zcopy
- ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
-FUNCTION: void cblas_zaxpy
- ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
-
-FUNCTION: void cblas_sscal
- ( int N, float alpha, float* X, int incX ) ;
-FUNCTION: void cblas_dscal
- ( int N, double alpha, double* X, int incX ) ;
-FUNCTION: void cblas_cscal
- ( int N, CBLAS_C* alpha, CBLAS_C* X, int incX ) ;
-FUNCTION: void cblas_zscal
- ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX ) ;
-FUNCTION: void cblas_csscal
- ( int N, float alpha, CBLAS_C* X, int incX ) ;
-FUNCTION: void cblas_zdscal
- ( int N, double alpha, CBLAS_Z* X, int incX ) ;
-
-FUNCTION: void cblas_srotg
- ( float* a, float* b, float* c, float* s ) ;
-FUNCTION: void cblas_srotmg
- ( float* d1, float* d2, float* b1, float b2, float* P ) ;
-FUNCTION: void cblas_srot
- ( int N, float* X, int incX, float* Y, int incY, float c, float s ) ;
-FUNCTION: void cblas_srotm
- ( int N, float* X, int incX, float* Y, int incY, float* P ) ;
-
-FUNCTION: void cblas_drotg
- ( double* a, double* b, double* c, double* s ) ;
-FUNCTION: void cblas_drotmg
- ( double* d1, double* d2, double* b1, double b2, double* P ) ;
-FUNCTION: void cblas_drot
- ( int N, double* X, int incX, double* Y, int incY, double c, double s ) ;
-FUNCTION: void cblas_drotm
- ( int N, double* X, int incX, double* Y, int incY, double* P ) ;
-
-! Level 2 BLAS (matrix-vector)
-
-FUNCTION: void cblas_sgemv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- float alpha, float* A, int lda,
- float* X, int incX, float beta,
- float* Y, int incY ) ;
-FUNCTION: void cblas_sgbmv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- int KL, int KU, float alpha,
- float* A, int lda, float* X,
- int incX, float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_strmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, float* A, int lda,
- float* X, int incX ) ;
-FUNCTION: void cblas_stbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, float* A, int lda,
- float* X, int incX ) ;
-FUNCTION: void cblas_stpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, float* Ap, float* X, int incX ) ;
-FUNCTION: void cblas_strsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, float* A, int lda, float* X,
- int incX ) ;
-FUNCTION: void cblas_stbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, float* A, int lda,
- float* X, int incX ) ;
-FUNCTION: void cblas_stpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, float* Ap, float* X, int incX ) ;
-
-FUNCTION: void cblas_dgemv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- double alpha, double* A, int lda,
- double* X, int incX, double beta,
- double* Y, int incY ) ;
-FUNCTION: void cblas_dgbmv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- int KL, int KU, double alpha,
- double* A, int lda, double* X,
- int incX, double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dtrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, double* A, int lda,
- double* X, int incX ) ;
-FUNCTION: void cblas_dtbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, double* A, int lda,
- double* X, int incX ) ;
-FUNCTION: void cblas_dtpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, double* Ap, double* X, int incX ) ;
-FUNCTION: void cblas_dtrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, double* A, int lda, double* X,
- int incX ) ;
-FUNCTION: void cblas_dtbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, double* A, int lda,
- double* X, int incX ) ;
-FUNCTION: void cblas_dtpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, double* Ap, double* X, int incX ) ;
-
-FUNCTION: void cblas_cgemv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- void* alpha, void* A, int lda,
- void* X, int incX, void* beta,
- void* Y, int incY ) ;
-FUNCTION: void cblas_cgbmv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- int KL, int KU, void* alpha,
- void* A, int lda, void* X,
- int incX, void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_ctrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ctbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ctpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* Ap, void* X, int incX ) ;
-FUNCTION: void cblas_ctrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* A, int lda, void* X,
- int incX ) ;
-FUNCTION: void cblas_ctbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ctpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* Ap, void* X, int incX ) ;
-
-FUNCTION: void cblas_zgemv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- void* alpha, void* A, int lda,
- void* X, int incX, void* beta,
- void* Y, int incY ) ;
-FUNCTION: void cblas_zgbmv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- int KL, int KU, void* alpha,
- void* A, int lda, void* X,
- int incX, void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_ztrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ztbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ztpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* Ap, void* X, int incX ) ;
-FUNCTION: void cblas_ztrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* A, int lda, void* X,
- int incX ) ;
-FUNCTION: void cblas_ztbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ztpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* Ap, void* X, int incX ) ;
-
-
-FUNCTION: void cblas_ssymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* A,
- int lda, float* X, int incX,
- float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_ssbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, int K, float alpha, float* A,
- int lda, float* X, int incX,
- float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_sspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* Ap,
- float* X, int incX,
- float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_sger ( CBLAS_ORDER Order, int M, int N,
- float alpha, float* X, int incX,
- float* Y, int incY, float* A, int lda ) ;
-FUNCTION: void cblas_ssyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* X,
- int incX, float* A, int lda ) ;
-FUNCTION: void cblas_sspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* X,
- int incX, float* Ap ) ;
-FUNCTION: void cblas_ssyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* X,
- int incX, float* Y, int incY, float* A,
- int lda ) ;
-FUNCTION: void cblas_sspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* X,
- int incX, float* Y, int incY, float* A ) ;
-
-FUNCTION: void cblas_dsymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* A,
- int lda, double* X, int incX,
- double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dsbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, int K, double alpha, double* A,
- int lda, double* X, int incX,
- double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* Ap,
- double* X, int incX,
- double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dger ( CBLAS_ORDER Order, int M, int N,
- double alpha, double* X, int incX,
- double* Y, int incY, double* A, int lda ) ;
-FUNCTION: void cblas_dsyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* X,
- int incX, double* A, int lda ) ;
-FUNCTION: void cblas_dspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* X,
- int incX, double* Ap ) ;
-FUNCTION: void cblas_dsyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* X,
- int incX, double* Y, int incY, double* A,
- int lda ) ;
-FUNCTION: void cblas_dspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* X,
- int incX, double* Y, int incY, double* A ) ;
-
-
-FUNCTION: void cblas_chemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, void* alpha, void* A,
- int lda, void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_chbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, int K, void* alpha, void* A,
- int lda, void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_chpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, void* alpha, void* Ap,
- void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_cgeru ( CBLAS_ORDER Order, int M, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_cgerc ( CBLAS_ORDER Order, int M, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_cher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, void* X, int incX,
- void* A, int lda ) ;
-FUNCTION: void cblas_chpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, void* X,
- int incX, void* A ) ;
-FUNCTION: void cblas_cher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_chpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* Ap ) ;
-
-FUNCTION: void cblas_zhemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, void* alpha, void* A,
- int lda, void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_zhbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, int K, void* alpha, void* A,
- int lda, void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_zhpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, void* alpha, void* Ap,
- void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_zgeru ( CBLAS_ORDER Order, int M, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_zgerc ( CBLAS_ORDER Order, int M, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_zher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, void* X, int incX,
- void* A, int lda ) ;
-FUNCTION: void cblas_zhpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, void* X,
- int incX, void* A ) ;
-FUNCTION: void cblas_zher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_zhpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* Ap ) ;
-
-! Level 3 BLAS (matrix-matrix)
-
-FUNCTION: void cblas_sgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
- CBLAS_TRANSPOSE TransB, int M, int N,
- int K, float alpha, float* A,
- int lda, float* B, int ldb,
- float beta, float* C, int ldc ) ;
-FUNCTION: void cblas_ssymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- float alpha, float* A, int lda,
- float* B, int ldb, float beta,
- float* C, int ldc ) ;
-FUNCTION: void cblas_ssyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- float alpha, float* A, int lda,
- float beta, float* C, int ldc ) ;
-FUNCTION: void cblas_ssyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- float alpha, float* A, int lda,
- float* B, int ldb, float beta,
- float* C, int ldc ) ;
-FUNCTION: void cblas_strmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- float alpha, float* A, int lda,
- float* B, int ldb ) ;
-FUNCTION: void cblas_strsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- float alpha, float* A, int lda,
- float* B, int ldb ) ;
-
-FUNCTION: void cblas_dgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
- CBLAS_TRANSPOSE TransB, int M, int N,
- int K, double alpha, double* A,
- int lda, double* B, int ldb,
- double beta, double* C, int ldc ) ;
-FUNCTION: void cblas_dsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- double alpha, double* A, int lda,
- double* B, int ldb, double beta,
- double* C, int ldc ) ;
-FUNCTION: void cblas_dsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- double alpha, double* A, int lda,
- double beta, double* C, int ldc ) ;
-FUNCTION: void cblas_dsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- double alpha, double* A, int lda,
- double* B, int ldb, double beta,
- double* C, int ldc ) ;
-FUNCTION: void cblas_dtrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- double alpha, double* A, int lda,
- double* B, int ldb ) ;
-FUNCTION: void cblas_dtrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- double alpha, double* A, int lda,
- double* B, int ldb ) ;
-
-FUNCTION: void cblas_cgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
- CBLAS_TRANSPOSE TransB, int M, int N,
- int K, void* alpha, void* A,
- int lda, void* B, int ldb,
- void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_csymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_csyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_csyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_ctrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb ) ;
-FUNCTION: void cblas_ctrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb ) ;
-
-FUNCTION: void cblas_zgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
- CBLAS_TRANSPOSE TransB, int M, int N,
- int K, void* alpha, void* A,
- int lda, void* B, int ldb,
- void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_zsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_zsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_zsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_ztrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb ) ;
-FUNCTION: void cblas_ztrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb ) ;
-
-FUNCTION: void cblas_chemm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_cherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- float alpha, void* A, int lda,
- float beta, void* C, int ldc ) ;
-FUNCTION: void cblas_cher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* B, int ldb, float beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_zhemm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_zherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- double alpha, void* A, int lda,
- double beta, void* C, int ldc ) ;
-FUNCTION: void cblas_zher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* B, int ldb, double beta,
- void* C, int ldc ) ;
-
+++ /dev/null
-Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library
+++ /dev/null
-math
-bindings
-unportable
+++ /dev/null
-USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
-IN: math.blas.matrices
-
-ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
-"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:"
-{ $subsection "math.blas-types" }
-"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
-{ $subsection "math.blas.vectors" }
-"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
-{ $subsection "math.blas.matrices" }
-"The low-level BLAS C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ;
-
-ARTICLE: "math.blas-types" "BLAS interface types"
-"BLAS vectors come in single- and double-precision, real and complex flavors:"
-{ $subsection float-blas-vector }
-{ $subsection double-blas-vector }
-{ $subsection float-complex-blas-vector }
-{ $subsection double-complex-blas-vector }
-"These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:"
-{ $subsection float-blas-matrix }
-{ $subsection double-blas-matrix }
-{ $subsection float-complex-blas-matrix }
-{ $subsection double-complex-blas-matrix }
-"Syntax words are provided for constructing literal vectors and matrices in the " { $vocab-link "math.blas.syntax" } " vocabulary:"
-{ $subsection "math.blas.syntax" }
-"There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
-{ $subsection <float-blas-vector> }
-{ $subsection <double-blas-vector> }
-{ $subsection <float-complex-blas-vector> }
-{ $subsection <double-complex-blas-vector> }
-{ $subsection <float-blas-matrix> }
-{ $subsection <double-blas-matrix> }
-{ $subsection <float-complex-blas-matrix> }
-{ $subsection <double-complex-blas-matrix> }
-"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
-{ $subsection <empty-vector> }
-{ $subsection <empty-matrix> }
-"BLAS vectors and matrices can also be constructed from other Factor sequences:"
-{ $subsection >float-blas-vector }
-{ $subsection >double-blas-vector }
-{ $subsection >float-complex-blas-vector }
-{ $subsection >double-complex-blas-vector }
-{ $subsection >float-blas-matrix }
-{ $subsection >double-blas-matrix }
-{ $subsection >float-complex-blas-matrix }
-{ $subsection >double-complex-blas-matrix } ;
-
-ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
-"Transposing and slicing matrices:"
-{ $subsection Mtranspose }
-{ $subsection Mrows }
-{ $subsection Mcols }
-{ $subsection Msub }
-"Matrix-vector products:"
-{ $subsection n*M.V+n*V! }
-{ $subsection n*M.V+n*V }
-{ $subsection n*M.V }
-{ $subsection M.V }
-"Vector outer products:"
-{ $subsection n*V(*)V+M! }
-{ $subsection n*V(*)Vconj+M! }
-{ $subsection n*V(*)V+M }
-{ $subsection n*V(*)Vconj+M }
-{ $subsection n*V(*)V }
-{ $subsection n*V(*)Vconj }
-{ $subsection V(*) }
-{ $subsection V(*)conj }
-"Matrix products:"
-{ $subsection n*M.M+n*M! }
-{ $subsection n*M.M+n*M }
-{ $subsection n*M.M }
-{ $subsection M. }
-"Scalar-matrix products:"
-{ $subsection n*M! }
-{ $subsection n*M }
-{ $subsection M*n }
-{ $subsection M/n } ;
-
-ABOUT: "math.blas.matrices"
-
-HELP: blas-matrix-base
-{ $class-description "The base class for all BLAS matrix types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:"
-{ $list
- { { $link float-blas-matrix } }
- { { $link double-blas-matrix } }
- { { $link float-complex-blas-matrix } }
- { { $link double-complex-blas-matrix } }
-}
-"All of these subclasses share the same tuple layout:"
-{ $list
- { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" }
- { { $snippet "ld" } " indicates the distance, in elements, between matrix columns;" }
- { { $snippet "rows" } " and " { $snippet "cols" } " indicate the number of significant rows and columns in the matrix;" }
- { "and " { $snippet "transpose" } ", if set to a true value, indicates that the matrix should be treated as transposed relative to its in-memory representation." }
-} } ;
-
-{ blas-vector-base blas-matrix-base } related-words
-
-HELP: float-blas-matrix
-{ $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-HELP: double-blas-matrix
-{ $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-HELP: float-complex-blas-matrix
-{ $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-HELP: double-complex-blas-matrix
-{ $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-
-{
- float-blas-matrix double-blas-matrix float-complex-blas-matrix double-complex-blas-matrix
- float-blas-vector double-blas-vector float-complex-blas-vector double-complex-blas-vector
-} related-words
-
-HELP: Mwidth
-{ $values { "matrix" blas-matrix-base } { "width" integer } }
-{ $description "Returns the number of columns in " { $snippet "matrix" } "." } ;
-
-HELP: Mheight
-{ $values { "matrix" blas-matrix-base } { "height" integer } }
-{ $description "Returns the number of rows in " { $snippet "matrix" } "." } ;
-
-{ Mwidth Mheight } related-words
-
-HELP: n*M.V+n*V!
-{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "y=alpha*A.x+b*y" blas-vector-base } }
-{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } ", and overwrite the current contents of " { $snippet "y" } " with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." }
-{ $side-effects "y" } ;
-
-HELP: n*V(*)V+M!
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)y+A" blas-matrix-base } }
-{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGER and xGERU routines in BLAS." }
-{ $side-effects "A" } ;
-
-HELP: n*V(*)Vconj+M!
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)yconj+A" blas-matrix-base } }
-{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGERC routines in BLAS." }
-{ $side-effects "A" } ;
-
-HELP: n*M.M+n*M!
-{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "C=alpha*A.B+beta*C" blas-matrix-base } }
-{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." }
-{ $side-effects "C" } ;
-
-HELP: <empty-matrix>
-{ $values { "rows" integer } { "cols" integer } { "exemplar" blas-vector-base blas-matrix-base } { "matrix" blas-matrix-base } }
-{ $description "Create a matrix of all zeros with the given dimensions and the same element type as " { $snippet "exemplar" } "." } ;
-
-{ <zero-vector> <empty-vector> <empty-matrix> } related-words
-
-HELP: n*M.V+n*V
-{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "alpha*A.x+b*y" blas-vector-base } }
-{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". The returned vector will have the same length as " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } ;
-
-HELP: n*V(*)V+M
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)y+A" blas-matrix-base } }
-{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
-
-HELP: n*V(*)Vconj+M
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)yconj+A" blas-matrix-base } }
-{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGERC routines in BLAS." } ;
-
-HELP: n*M.M+n*M
-{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "alpha*A.B+beta*C" blas-matrix-base } }
-{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ;
-
-HELP: n*M.V
-{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "alpha*A.x" blas-vector-base } }
-{ $description "Calculate the matrix-vector product " { $snippet "αAx" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
-
-HELP: M.V
-{ $values { "A" blas-matrix-base } { "x" blas-vector-base } { "A.x" blas-vector-base } }
-{ $description "Calculate the matrix-vector product " { $snippet "Ax" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
-
-{ n*M.V+n*V! n*M.V+n*V n*M.V M.V } related-words
-
-HELP: n*V(*)V
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)y" blas-matrix-base } }
-{ $description "Calculate the outer product " { $snippet "αx⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
-
-HELP: n*V(*)Vconj
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)yconj" blas-matrix-base } }
-{ $description "Calculate the outer product " { $snippet "αx⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
-
-HELP: V(*)
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)y" blas-matrix-base } }
-{ $description "Calculate the outer product " { $snippet "x⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
-
-HELP: V(*)conj
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)yconj" blas-matrix-base } }
-{ $description "Calculate the conjugate outer product " { $snippet "x⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
-
-{ n*V(*)V+M! n*V(*)Vconj+M! n*V(*)V+M n*V(*)Vconj+M n*V(*)V n*V(*)Vconj V(*) V(*)conj V. V.conj } related-words
-
-HELP: n*M.M
-{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "alpha*A.B" blas-matrix-base } }
-{ $description "Calculate the matrix product " { $snippet "αAB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
-
-HELP: M.
-{ $values { "A" blas-matrix-base } { "B" blas-matrix-base } { "A.B" blas-matrix-base } }
-{ $description "Calculate the matrix product " { $snippet "AB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
-
-{ n*M.M+n*M! n*M.M+n*M n*M.M M. } related-words
-
-HELP: Msub
-{ $values { "matrix" blas-matrix-base } { "row" integer } { "col" integer } { "height" integer } { "width" integer } { "sub" blas-matrix-base } }
-{ $description "Select a rectangular submatrix of " { $snippet "matrix" } " with the given dimensions. The returned submatrix will share the parent matrix's storage." } ;
-
-HELP: Mrows
-{ $values { "A" blas-matrix-base } { "rows" sequence } }
-{ $description "Return a sequence of BLAS vectors representing the rows of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
-
-HELP: Mcols
-{ $values { "A" blas-matrix-base } { "cols" sequence } }
-{ $description "Return a sequence of BLAS vectors representing the columns of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
-
-HELP: n*M!
-{ $values { "n" number } { "A" blas-matrix-base } { "A=n*A" blas-matrix-base } }
-{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and overwrite the current contents of A with the result." }
-{ $side-effects "A" } ;
-
-HELP: n*M
-{ $values { "n" number } { "A" blas-matrix-base } { "n*A" blas-matrix-base } }
-{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
-
-HELP: M*n
-{ $values { "A" blas-matrix-base } { "n" number } { "A*n" blas-matrix-base } }
-{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
-
-HELP: M/n
-{ $values { "A" blas-matrix-base } { "n" number } { "A/n" blas-matrix-base } }
-{ $description "Calculate the scalar-matrix product " { $snippet "(1/n)A" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
-
-{ n*M! n*M M*n M/n } related-words
-
-HELP: Mtranspose
-{ $values { "matrix" blas-matrix-base } { "matrix^T" blas-matrix-base } }
-{ $description "Returns the transpose of " { $snippet "matrix" } ". The returned matrix shares storage with the original matrix." } ;
-
-HELP: element-type
-{ $values { "v" blas-vector-base blas-matrix-base } { "type" string } }
-{ $description "Return the C type of the elements in the given BLAS vector or matrix." } ;
-
-HELP: <empty-vector>
-{ $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } }
-{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
-
+++ /dev/null
-USING: kernel math.blas.matrices math.blas.vectors math.blas.syntax
-sequences tools.test ;
-IN: math.blas.matrices.tests
-
-! clone
-
-[ smatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
-} ] [
- smatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
- } clone
-] unit-test
-[ f ] [
- smatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
- } dup clone eq?
-] unit-test
-
-[ dmatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
-} ] [
- dmatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
- } clone
-] unit-test
-[ f ] [
- dmatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
- } dup clone eq?
-] unit-test
-
-[ cmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
-} ] [
- cmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
- } clone
-] unit-test
-[ f ] [
- cmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
- } dup clone eq?
-] unit-test
-
-[ zmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
-} ] [
- zmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
- } clone
-] unit-test
-[ f ] [
- zmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
- } dup clone eq?
-] unit-test
-
-! M.V
-
-[ svector{ 3.0 1.0 6.0 } ] [
- smatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 0.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- }
- svector{ 1.0 2.0 3.0 1.0 }
- M.V
-] unit-test
-[ svector{ -2.0 1.0 3.0 14.0 } ] [
- smatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 0.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- } Mtranspose
- svector{ 1.0 2.0 3.0 }
- M.V
-] unit-test
-
-[ dvector{ 3.0 1.0 6.0 } ] [
- dmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 0.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- }
- dvector{ 1.0 2.0 3.0 1.0 }
- M.V
-] unit-test
-[ dvector{ -2.0 1.0 3.0 14.0 } ] [
- dmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 0.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- } Mtranspose
- dvector{ 1.0 2.0 3.0 }
- M.V
-] unit-test
-
-[ cvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [
- cmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- }
- cvector{ 1.0 2.0 3.0 1.0 }
- M.V
-] unit-test
-[ cvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [
- cmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- } Mtranspose
- cvector{ 1.0 2.0 3.0 }
- M.V
-] unit-test
-
-[ zvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [
- zmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- }
- zvector{ 1.0 2.0 3.0 1.0 }
- M.V
-] unit-test
-[ zvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [
- zmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- } Mtranspose
- zvector{ 1.0 2.0 3.0 }
- M.V
-] unit-test
-
-! V(*)
-
-[ smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 4.0 6.0 8.0 }
- { 3.0 6.0 9.0 12.0 }
-} ] [
- svector{ 1.0 2.0 3.0 } svector{ 1.0 2.0 3.0 4.0 } V(*)
-] unit-test
-
-[ dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 4.0 6.0 8.0 }
- { 3.0 6.0 9.0 12.0 }
-} ] [
- dvector{ 1.0 2.0 3.0 } dvector{ 1.0 2.0 3.0 4.0 } V(*)
-] unit-test
-
-[ cmatrix{
- { 1.0 2.0 C{ 3.0 -3.0 } 4.0 }
- { 2.0 4.0 C{ 6.0 -6.0 } 8.0 }
- { C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } }
-} ] [
- cvector{ 1.0 2.0 C{ 3.0 3.0 } } cvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*)
-] unit-test
-
-[ zmatrix{
- { 1.0 2.0 C{ 3.0 -3.0 } 4.0 }
- { 2.0 4.0 C{ 6.0 -6.0 } 8.0 }
- { C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } }
-} ] [
- zvector{ 1.0 2.0 C{ 3.0 3.0 } } zvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*)
-] unit-test
-
-! M.
-
-[ smatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 0.0 -3.0 0.0 0.0 }
- { 0.0 4.0 0.0 0.0 10.0 }
- { 0.0 0.0 0.0 0.0 0.0 }
-} ] [
- smatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } smatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 2.0 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } M.
-] unit-test
-
-[ smatrix{
- { 1.0 0.0 0.0 0.0 }
- { 0.0 0.0 4.0 0.0 }
- { 0.0 -3.0 0.0 0.0 }
- { 4.0 0.0 0.0 0.0 }
- { 0.0 0.0 10.0 0.0 }
-} ] [
- smatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 2.0 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } Mtranspose smatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } Mtranspose M.
-] unit-test
-
-[ dmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 0.0 -3.0 0.0 0.0 }
- { 0.0 4.0 0.0 0.0 10.0 }
- { 0.0 0.0 0.0 0.0 0.0 }
-} ] [
- dmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } dmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 2.0 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } M.
-] unit-test
-
-[ dmatrix{
- { 1.0 0.0 0.0 0.0 }
- { 0.0 0.0 4.0 0.0 }
- { 0.0 -3.0 0.0 0.0 }
- { 4.0 0.0 0.0 0.0 }
- { 0.0 0.0 10.0 0.0 }
-} ] [
- dmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 2.0 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } Mtranspose dmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } Mtranspose M.
-] unit-test
-
-[ cmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 0.0 -3.0 0.0 0.0 }
- { 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 }
- { 0.0 0.0 0.0 0.0 0.0 }
-} ] [
- cmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } cmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } M.
-] unit-test
-
-[ cmatrix{
- { 1.0 0.0 0.0 0.0 }
- { 0.0 0.0 C{ 4.0 -4.0 } 0.0 }
- { 0.0 -3.0 0.0 0.0 }
- { 4.0 0.0 0.0 0.0 }
- { 0.0 0.0 10.0 0.0 }
-} ] [
- cmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } Mtranspose cmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } Mtranspose M.
-] unit-test
-
-[ zmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 0.0 -3.0 0.0 0.0 }
- { 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 }
- { 0.0 0.0 0.0 0.0 0.0 }
-} ] [
- zmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } zmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } M.
-] unit-test
-
-[ zmatrix{
- { 1.0 0.0 0.0 0.0 }
- { 0.0 0.0 C{ 4.0 -4.0 } 0.0 }
- { 0.0 -3.0 0.0 0.0 }
- { 4.0 0.0 0.0 0.0 }
- { 0.0 0.0 10.0 0.0 }
-} ] [
- zmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } Mtranspose zmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } Mtranspose M.
-] unit-test
-
-! n*M
-
-[ smatrix{
- { 2.0 0.0 }
- { 0.0 2.0 }
-} ] [
- 2.0 smatrix{
- { 1.0 0.0 }
- { 0.0 1.0 }
- } n*M
-] unit-test
-
-[ dmatrix{
- { 2.0 0.0 }
- { 0.0 2.0 }
-} ] [
- 2.0 dmatrix{
- { 1.0 0.0 }
- { 0.0 1.0 }
- } n*M
-] unit-test
-
-[ cmatrix{
- { C{ 2.0 1.0 } 0.0 }
- { 0.0 C{ -1.0 2.0 } }
-} ] [
- C{ 2.0 1.0 } cmatrix{
- { 1.0 0.0 }
- { 0.0 C{ 0.0 1.0 } }
- } n*M
-] unit-test
-
-[ zmatrix{
- { C{ 2.0 1.0 } 0.0 }
- { 0.0 C{ -1.0 2.0 } }
-} ] [
- C{ 2.0 1.0 } zmatrix{
- { 1.0 0.0 }
- { 0.0 C{ 0.0 1.0 } }
- } n*M
-] unit-test
-
-! Mrows, Mcols
-
-[ svector{ 3.0 3.0 3.0 } ] [
- 2 smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mcols nth
-] unit-test
-[ svector{ 3.0 2.0 3.0 4.0 } ] [
- 2 smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mrows nth
-] unit-test
-[ 3 ] [
- smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mrows length
-] unit-test
-[ 4 ] [
- smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mcols length
-] unit-test
-[ svector{ 3.0 3.0 3.0 } ] [
- 2 smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mrows nth
-] unit-test
-[ svector{ 3.0 2.0 3.0 4.0 } ] [
- 2 smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mcols nth
-] unit-test
-[ 3 ] [
- smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mcols length
-] unit-test
-[ 4 ] [
- smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mrows length
-] unit-test
-
-[ dvector{ 3.0 3.0 3.0 } ] [
- 2 dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mcols nth
-] unit-test
-[ dvector{ 3.0 2.0 3.0 4.0 } ] [
- 2 dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mrows nth
-] unit-test
-[ 3 ] [
- dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mrows length
-] unit-test
-[ 4 ] [
- dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mcols length
-] unit-test
-[ dvector{ 3.0 3.0 3.0 } ] [
- 2 dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mrows nth
-] unit-test
-[ dvector{ 3.0 2.0 3.0 4.0 } ] [
- 2 dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mcols nth
-] unit-test
-[ 3 ] [
- dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mcols length
-] unit-test
-[ 4 ] [
- dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mrows length
-] unit-test
-
-[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
- 2 cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mcols nth
-] unit-test
-[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
- 2 cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mrows nth
-] unit-test
-[ 3 ] [
- cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mrows length
-] unit-test
-[ 4 ] [
- cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mcols length
-] unit-test
-[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
- 2 cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mrows nth
-] unit-test
-[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
- 2 cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mcols nth
-] unit-test
-[ 3 ] [
- cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mcols length
-] unit-test
-[ 4 ] [
- cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mrows length
-] unit-test
-
-[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
- 2 zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mcols nth
-] unit-test
-[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
- 2 zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mrows nth
-] unit-test
-[ 3 ] [
- zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mrows length
-] unit-test
-[ 4 ] [
- zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mcols length
-] unit-test
-[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
- 2 zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mrows nth
-] unit-test
-[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
- 2 zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mcols nth
-] unit-test
-[ 3 ] [
- zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mcols length
-] unit-test
-[ 4 ] [
- zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mrows length
-] unit-test
-
-! Msub
-
-[ smatrix{
- { 3.0 2.0 1.0 }
- { 0.0 1.0 0.0 }
-} ] [
- smatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 3.0 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } 1 2 2 3 Msub
-] unit-test
-
-[ smatrix{
- { 3.0 0.0 }
- { 2.0 1.0 }
- { 1.0 0.0 }
-} ] [
- smatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 3.0 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } Mtranspose 2 1 3 2 Msub
-] unit-test
-
-[ dmatrix{
- { 3.0 2.0 1.0 }
- { 0.0 1.0 0.0 }
-} ] [
- dmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 3.0 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } 1 2 2 3 Msub
-] unit-test
-
-[ dmatrix{
- { 3.0 0.0 }
- { 2.0 1.0 }
- { 1.0 0.0 }
-} ] [
- dmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 3.0 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } Mtranspose 2 1 3 2 Msub
-] unit-test
-
-[ cmatrix{
- { C{ 3.0 3.0 } 2.0 1.0 }
- { 0.0 1.0 0.0 }
-} ] [
- cmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } 1 2 2 3 Msub
-] unit-test
-
-[ cmatrix{
- { C{ 3.0 3.0 } 0.0 }
- { 2.0 1.0 }
- { 1.0 0.0 }
-} ] [
- cmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } Mtranspose 2 1 3 2 Msub
-] unit-test
-
-[ zmatrix{
- { C{ 3.0 3.0 } 2.0 1.0 }
- { 0.0 1.0 0.0 }
-} ] [
- zmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } 1 2 2 3 Msub
-] unit-test
-
-[ zmatrix{
- { C{ 3.0 3.0 } 0.0 }
- { 2.0 1.0 }
- { 1.0 0.0 }
-} ] [
- zmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } Mtranspose 2 1 3 2 Msub
-] unit-test
-
+++ /dev/null
-USING: accessors alien alien.c-types arrays byte-arrays combinators
-combinators.lib combinators.short-circuit fry kernel locals macros
-math math.blas.cblas math.blas.vectors math.blas.vectors.private
-math.complex math.functions math.order multi-methods qualified
-sequences sequences.merged sequences.private generalizations
-shuffle symbols speicalized-arrays.float specialized-arrays.double ;
-QUALIFIED: syntax
-IN: math.blas.matrices
-
-TUPLE: blas-matrix-base data ld rows cols transpose ;
-TUPLE: float-blas-matrix < blas-matrix-base ;
-TUPLE: double-blas-matrix < blas-matrix-base ;
-TUPLE: float-complex-blas-matrix < blas-matrix-base ;
-TUPLE: double-complex-blas-matrix < blas-matrix-base ;
-
-C: <float-blas-matrix> float-blas-matrix
-C: <double-blas-matrix> double-blas-matrix
-C: <float-complex-blas-matrix> float-complex-blas-matrix
-C: <double-complex-blas-matrix> double-complex-blas-matrix
-
-METHOD: element-type { float-blas-matrix }
- drop "float" ;
-METHOD: element-type { double-blas-matrix }
- drop "double" ;
-METHOD: element-type { float-complex-blas-matrix }
- drop "CBLAS_C" ;
-METHOD: element-type { double-complex-blas-matrix }
- drop "CBLAS_Z" ;
-
-: Mtransposed? ( matrix -- ? )
- transpose>> ; inline
-: Mwidth ( matrix -- width )
- dup Mtransposed? [ rows>> ] [ cols>> ] if ; inline
-: Mheight ( matrix -- height )
- dup Mtransposed? [ cols>> ] [ rows>> ] if ; inline
-
-<PRIVATE
-
-: (blas-transpose) ( matrix -- integer )
- transpose>> [ CblasTrans ] [ CblasNoTrans ] if ;
-
-GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
-
-METHOD: (blas-matrix-like) { object object object object object float-blas-matrix }
- drop <float-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object double-blas-matrix }
- drop <double-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object float-complex-blas-matrix }
- drop <float-complex-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object double-complex-blas-matrix }
- drop <double-complex-blas-matrix> ;
-
-METHOD: (blas-matrix-like) { object object object object object float-blas-vector }
- drop <float-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object double-blas-vector }
- drop <double-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object float-complex-blas-vector }
- drop <float-complex-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object double-complex-blas-vector }
- drop <double-complex-blas-matrix> ;
-
-METHOD: (blas-vector-like) { object object object float-blas-matrix }
- drop <float-blas-vector> ;
-METHOD: (blas-vector-like) { object object object double-blas-matrix }
- drop <double-blas-vector> ;
-METHOD: (blas-vector-like) { object object object float-complex-blas-matrix }
- drop <float-complex-blas-vector> ;
-METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
- drop <double-complex-blas-vector> ;
-
-: (validate-gemv) ( A x y -- )
- {
- [ drop [ Mwidth ] [ length>> ] bi* = ]
- [ nip [ Mheight ] [ length>> ] bi* = ]
- } 3&&
- [ "Mismatched matrix and vectors in matrix-vector multiplication" throw ] unless ;
-
-:: (prepare-gemv) ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc y )
- A x y (validate-gemv)
- CblasColMajor
- A (blas-transpose)
- A rows>>
- A cols>>
- alpha >c-arg call
- A data>>
- A ld>>
- x data>>
- x inc>>
- beta >c-arg call
- y data>>
- y inc>>
- y ; inline
-
-: (validate-ger) ( x y A -- )
- {
- [ nip [ length>> ] [ Mheight ] bi* = ]
- [ nipd [ length>> ] [ Mwidth ] bi* = ]
- } 3&&
- [ "Mismatched vertices and matrix in vector outer product" throw ] unless ;
-
-:: (prepare-ger) ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld A )
- x y A (validate-ger)
- CblasColMajor
- A rows>>
- A cols>>
- alpha >c-arg call
- x data>>
- x inc>>
- y data>>
- y inc>>
- A data>>
- A ld>>
- A f >>transpose ; inline
-
-: (validate-gemm) ( A B C -- )
- {
- [ drop [ Mwidth ] [ Mheight ] bi* = ]
- [ nip [ Mheight ] bi@ = ]
- [ nipd [ Mwidth ] bi@ = ]
- } 3&& [ "Mismatched matrices in matrix multiplication" throw ] unless ;
-
-:: (prepare-gemm) ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld C )
- A B C (validate-gemm)
- CblasColMajor
- A (blas-transpose)
- B (blas-transpose)
- C rows>>
- C cols>>
- A Mwidth
- alpha >c-arg call
- A data>>
- A ld>>
- B data>>
- B ld>>
- beta >c-arg call
- C data>>
- C ld>>
- C f >>transpose ; inline
-
-: (>matrix) ( arrays >c-array -- c-array ld rows cols transpose )
- '[ <merged> @ ] [ length dup ] [ first length ] tri f ; inline
-
-PRIVATE>
-
-: >float-blas-matrix ( arrays -- matrix )
- [ >float-array underlying>> ] (>matrix) <float-blas-matrix> ;
-: >double-blas-matrix ( arrays -- matrix )
- [ >double-array underlying>> ] (>matrix) <double-blas-matrix> ;
-: >float-complex-blas-matrix ( arrays -- matrix )
- [ (flatten-complex-sequence) >float-array underlying>> ] (>matrix)
- <float-complex-blas-matrix> ;
-: >double-complex-blas-matrix ( arrays -- matrix )
- [ (flatten-complex-sequence) >double-array underlying>> ] (>matrix)
- <double-complex-blas-matrix> ;
-
-GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
-GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
-GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
-GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
-
-METHOD: n*M.V+n*V! { real float-blas-matrix float-blas-vector real float-blas-vector }
- [ ] (prepare-gemv) [ cblas_sgemv ] dip ;
-METHOD: n*M.V+n*V! { real double-blas-matrix double-blas-vector real double-blas-vector }
- [ ] (prepare-gemv) [ cblas_dgemv ] dip ;
-METHOD: n*M.V+n*V! { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector }
- [ (>c-complex) ] (prepare-gemv) [ cblas_cgemv ] dip ;
-METHOD: n*M.V+n*V! { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector }
- [ (>z-complex) ] (prepare-gemv) [ cblas_zgemv ] dip ;
-
-METHOD: n*V(*)V+M! { real float-blas-vector float-blas-vector float-blas-matrix }
- [ ] (prepare-ger) [ cblas_sger ] dip ;
-METHOD: n*V(*)V+M! { real double-blas-vector double-blas-vector double-blas-matrix }
- [ ] (prepare-ger) [ cblas_dger ] dip ;
-METHOD: n*V(*)V+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
- [ (>c-complex) ] (prepare-ger) [ cblas_cgeru ] dip ;
-METHOD: n*V(*)V+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
- [ (>z-complex) ] (prepare-ger) [ cblas_zgeru ] dip ;
-
-METHOD: n*V(*)Vconj+M! { real float-blas-vector float-blas-vector float-blas-matrix }
- [ ] (prepare-ger) [ cblas_sger ] dip ;
-METHOD: n*V(*)Vconj+M! { real double-blas-vector double-blas-vector double-blas-matrix }
- [ ] (prepare-ger) [ cblas_dger ] dip ;
-METHOD: n*V(*)Vconj+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
- [ (>c-complex) ] (prepare-ger) [ cblas_cgerc ] dip ;
-METHOD: n*V(*)Vconj+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
- [ (>z-complex) ] (prepare-ger) [ cblas_zgerc ] dip ;
-
-METHOD: n*M.M+n*M! { real float-blas-matrix float-blas-matrix real float-blas-matrix }
- [ ] (prepare-gemm) [ cblas_sgemm ] dip ;
-METHOD: n*M.M+n*M! { real double-blas-matrix double-blas-matrix real double-blas-matrix }
- [ ] (prepare-gemm) [ cblas_dgemm ] dip ;
-METHOD: n*M.M+n*M! { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix }
- [ (>c-complex) ] (prepare-gemm) [ cblas_cgemm ] dip ;
-METHOD: n*M.M+n*M! { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix }
- [ (>z-complex) ] (prepare-gemm) [ cblas_zgemm ] dip ;
-
-! XXX should do a dense clone
-syntax:M: blas-matrix-base clone
- [
- [
- { [ data>> ] [ ld>> ] [ cols>> ] [ element-type heap-size ] } cleave
- * * memory>byte-array
- ] [ { [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> ] } cleave ] bi
- ] keep (blas-matrix-like) ;
-
-! XXX try rounding stride to next 128 bit bound for better vectorizin'
-: <empty-matrix> ( rows cols exemplar -- matrix )
- [ element-type [ * ] dip <c-array> ]
- [ 2drop ]
- [ f swap (blas-matrix-like) ] 3tri ;
-
-: n*M.V+n*V ( alpha A x beta y -- alpha*A.x+b*y )
- clone n*M.V+n*V! ;
-: n*V(*)V+M ( alpha x y A -- alpha*x(*)y+A )
- clone n*V(*)V+M! ;
-: n*V(*)Vconj+M ( alpha x y A -- alpha*x(*)yconj+A )
- clone n*V(*)Vconj+M! ;
-: n*M.M+n*M ( alpha A B beta C -- alpha*A.B+beta*C )
- clone n*M.M+n*M! ;
-
-: n*M.V ( alpha A x -- alpha*A.x )
- 1.0 2over [ Mheight ] dip <empty-vector>
- n*M.V+n*V! ; inline
-
-: M.V ( A x -- A.x )
- 1.0 -rot n*M.V ; inline
-
-: n*V(*)V ( alpha x y -- alpha*x(*)y )
- 2dup [ length>> ] bi@ pick <empty-matrix>
- n*V(*)V+M! ;
-: n*V(*)Vconj ( alpha x y -- alpha*x(*)yconj )
- 2dup [ length>> ] bi@ pick <empty-matrix>
- n*V(*)Vconj+M! ;
-
-: V(*) ( x y -- x(*)y )
- 1.0 -rot n*V(*)V ; inline
-: V(*)conj ( x y -- x(*)yconj )
- 1.0 -rot n*V(*)Vconj ; inline
-
-: n*M.M ( alpha A B -- alpha*A.B )
- 2dup [ Mheight ] [ Mwidth ] bi* pick <empty-matrix>
- 1.0 swap n*M.M+n*M! ;
-
-: M. ( A B -- A.B )
- 1.0 -rot n*M.M ; inline
-
-:: (Msub) ( matrix row col height width -- data ld rows cols )
- matrix ld>> col * row + matrix element-type heap-size *
- matrix data>> <displaced-alien>
- matrix ld>>
- height
- width ;
-
-: Msub ( matrix row col height width -- sub )
- 5 npick dup transpose>>
- [ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep
- swap (blas-matrix-like) ;
-
-TUPLE: blas-matrix-rowcol-sequence parent inc rowcol-length rowcol-jump length ;
-C: <blas-matrix-rowcol-sequence> blas-matrix-rowcol-sequence
-
-INSTANCE: blas-matrix-rowcol-sequence sequence
-
-syntax:M: blas-matrix-rowcol-sequence length
- length>> ;
-syntax:M: blas-matrix-rowcol-sequence nth-unsafe
- {
- [
- [ rowcol-jump>> ]
- [ parent>> element-type heap-size ]
- [ parent>> data>> ] tri
- [ * * ] dip <displaced-alien>
- ]
- [ rowcol-length>> ]
- [ inc>> ]
- [ parent>> ]
- } cleave (blas-vector-like) ;
-
-: (Mcols) ( A -- columns )
- { [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] } cleave
- <blas-matrix-rowcol-sequence> ;
-: (Mrows) ( A -- rows )
- { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] } cleave
- <blas-matrix-rowcol-sequence> ;
-
-: Mrows ( A -- rows )
- dup transpose>> [ (Mcols) ] [ (Mrows) ] if ;
-: Mcols ( A -- cols )
- dup transpose>> [ (Mrows) ] [ (Mcols) ] if ;
-
-: n*M! ( n A -- A=n*A )
- [ (Mcols) [ n*V! drop ] with each ] keep ;
-
-: n*M ( n A -- n*A )
- clone n*M! ; inline
-
-: M*n ( A n -- A*n )
- swap n*M ; inline
-: M/n ( A n -- A/n )
- recip swap n*M ; inline
-
-: Mtranspose ( matrix -- matrix^T )
- [ { [ data>> ] [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> not ] } cleave ] keep (blas-matrix-like) ;
-
-syntax:M: blas-matrix-base equal?
- {
- [ [ Mwidth ] bi@ = ]
- [ [ Mcols ] bi@ [ = ] 2all? ]
- } 2&& ;
-
+++ /dev/null
-BLAS level 2 and 3 matrix-vector and matrix-matrix operations
+++ /dev/null
-math
-bindings
-unportable
+++ /dev/null
-Literal syntax for BLAS vectors and matrices
+++ /dev/null
-USING: help.markup help.syntax math.blas.matrices math.blas.vectors multiline ;
-IN: math.blas.syntax
-
-ARTICLE: "math.blas.syntax" "BLAS interface literal syntax"
-"Vectors:"
-{ $subsection POSTPONE: svector{ }
-{ $subsection POSTPONE: dvector{ }
-{ $subsection POSTPONE: cvector{ }
-{ $subsection POSTPONE: zvector{ }
-"Matrices:"
-{ $subsection POSTPONE: smatrix{ }
-{ $subsection POSTPONE: dmatrix{ }
-{ $subsection POSTPONE: cmatrix{ }
-{ $subsection POSTPONE: zmatrix{ } ;
-
-ABOUT: "math.blas.syntax"
-
-HELP: svector{
-{ $syntax "svector{ 1.0 -2.0 3.0 }" }
-{ $description "Construct a literal " { $link float-blas-vector } "." } ;
-
-HELP: dvector{
-{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
-{ $description "Construct a literal " { $link double-blas-vector } "." } ;
-
-HELP: cvector{
-{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
-{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
-
-HELP: zvector{
-{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
-{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
-
-{
- POSTPONE: svector{ POSTPONE: dvector{
- POSTPONE: cvector{ POSTPONE: zvector{
-} related-words
-
-HELP: smatrix{
-{ $syntax <" smatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 1.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- { 0.0 0.0 0.0 1.0 }
-} "> }
-{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-HELP: dmatrix{
-{ $syntax <" dmatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 1.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- { 0.0 0.0 0.0 1.0 }
-} "> }
-{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-HELP: cmatrix{
-{ $syntax <" cmatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 -1.0 3.0 }
- { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
-} "> }
-{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-HELP: zmatrix{
-{ $syntax <" zmatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 -1.0 3.0 }
- { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
-} "> }
-{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-{
- POSTPONE: smatrix{ POSTPONE: dmatrix{
- POSTPONE: cmatrix{ POSTPONE: zmatrix{
-} related-words
+++ /dev/null
-USING: kernel math.blas.matrices math.blas.vectors parser
-arrays prettyprint.backend sequences ;
-IN: math.blas.syntax
-
-: svector{
- \ } [ >float-blas-vector ] parse-literal ; parsing
-: dvector{
- \ } [ >double-blas-vector ] parse-literal ; parsing
-: cvector{
- \ } [ >float-complex-blas-vector ] parse-literal ; parsing
-: zvector{
- \ } [ >double-complex-blas-vector ] parse-literal ; parsing
-
-: smatrix{
- \ } [ >float-blas-matrix ] parse-literal ; parsing
-: dmatrix{
- \ } [ >double-blas-matrix ] parse-literal ; parsing
-: cmatrix{
- \ } [ >float-complex-blas-matrix ] parse-literal ; parsing
-: zmatrix{
- \ } [ >double-complex-blas-matrix ] parse-literal ; parsing
-
-M: float-blas-vector pprint-delims drop \ svector{ \ } ;
-M: double-blas-vector pprint-delims drop \ dvector{ \ } ;
-M: float-complex-blas-vector pprint-delims drop \ cvector{ \ } ;
-M: double-complex-blas-vector pprint-delims drop \ zvector{ \ } ;
-
-M: float-blas-matrix pprint-delims drop \ smatrix{ \ } ;
-M: double-blas-matrix pprint-delims drop \ dmatrix{ \ } ;
-M: float-complex-blas-matrix pprint-delims drop \ cmatrix{ \ } ;
-M: double-complex-blas-matrix pprint-delims drop \ zmatrix{ \ } ;
-
-M: blas-vector-base >pprint-sequence ;
-M: blas-vector-base pprint* pprint-object ;
-M: blas-matrix-base >pprint-sequence Mrows ;
-M: blas-matrix-base pprint* pprint-object ;
+++ /dev/null
-math
-unportable
+++ /dev/null
-BLAS level 1 vector operations
+++ /dev/null
-math
-unportable
+++ /dev/null
-USING: alien byte-arrays help.markup help.syntax math sequences ;
-IN: math.blas.vectors
-
-ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
-"Slicing vectors:"
-{ $subsection Vsub }
-"Taking the norm (magnitude) of a vector:"
-{ $subsection Vnorm }
-"Summing and taking the maximum of elements:"
-{ $subsection Vasum }
-{ $subsection Viamax }
-{ $subsection Vamax }
-"Scalar-vector products:"
-{ $subsection n*V! }
-{ $subsection n*V }
-{ $subsection V*n }
-{ $subsection V/n }
-{ $subsection Vneg }
-"Vector addition:"
-{ $subsection n*V+V! }
-{ $subsection n*V+V }
-{ $subsection V+ }
-{ $subsection V- }
-"Vector inner products:"
-{ $subsection V. }
-{ $subsection V.conj } ;
-
-ABOUT: "math.blas.vectors"
-
-HELP: blas-vector-base
-{ $class-description "The base class for all BLAS vector types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:"
-{ $list
- { { $link float-blas-vector } }
- { { $link double-blas-vector } }
- { { $link float-complex-blas-vector } }
- { { $link double-complex-blas-vector } }
-}
-"All of these subclasses share the same tuple layout:"
-{ $list
- { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
- { { $snippet "length" } " indicates the length of the vector;" }
- { "and " { $snippet "inc" } " indicates the distance, in elements, between elements." }
-} } ;
-
-HELP: float-blas-vector
-{ $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: double-blas-vector
-{ $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: float-complex-blas-vector
-{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: double-complex-blas-vector
-{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-
-HELP: n*V+V!
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } }
-{ $description "Calculate the vector sum " { $snippet "αx + y" } " and replace the existing contents of y with the result. Corresponds to the xAXPY routines in BLAS." }
-{ $side-effects "y" } ;
-
-HELP: n*V!
-{ $values { "alpha" number } { "x" blas-vector-base } { "x=alpha*x" blas-vector-base } }
-{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and replace the existing contents of x with the result. Corresponds to the xSCAL routines in BLAS." }
-{ $side-effects "x" } ;
-
-HELP: V.
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x.y" number } }
-{ $description "Calculate the inner product " { $snippet "x⋅y" } ". Corresponds to the xDOT and xDOTU routines in BLAS." } ;
-
-HELP: V.conj
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "xconj.y" number } }
-{ $description "Calculate the conjugate inner product " { $snippet "x̅⋅y" } ". Corresponds to the xDOTC routines in BLAS." } ;
-
-HELP: Vnorm
-{ $values { "x" blas-vector-base } { "norm" number } }
-{ $description "Calculate the norm-2, i.e., the magnitude or absolute value, of " { $snippet "x" } " (" { $snippet "‖x‖₂" } "). Corresponds to the xNRM2 routines in BLAS." } ;
-
-HELP: Vasum
-{ $values { "x" blas-vector-base } { "sum" number } }
-{ $description "Calculate the sum of the norm-1s of the elements of " { $snippet "x" } " (" { $snippet "Σ ‖xᵢ‖₁" } "). Corresponds to the xASUM routines in BLAS." } ;
-
-HELP: Vswap
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x=y" blas-vector-base } { "y=x" blas-vector-base } }
-{ $description "Swap the contents of " { $snippet "x" } " and " { $snippet "y" } " in place. Corresponds to the xSWAP routines in BLAS." }
-{ $side-effects "x" "y" } ;
-
-HELP: Viamax
-{ $values { "x" blas-vector-base } { "max-i" integer } }
-{ $description "Return the index of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the smallest index. Corresponds to the IxAMAX routines in BLAS." } ;
-
-HELP: Vamax
-{ $values { "x" blas-vector-base } { "max" number } }
-{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the first element. Corresponds to the IxAMAX routines in BLAS." } ;
-
-{ Viamax Vamax } related-words
-
-HELP: <zero-vector>
-{ $values { "exemplar" blas-vector-base } { "zero" blas-vector-base } }
-{ $description "Return a vector of zeros with the same length and element type as " { $snippet "v" } ". The vector is constructed with an " { $snippet "inc" } " of zero, so it is not suitable for receiving results from BLAS functions; it is intended to be used as a term in other vector calculations. To construct an empty vector that can be used to receive results, see " { $link <empty-vector> } "." } ;
-
-HELP: n*V+V
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x+y" blas-vector-base } }
-{ $description "Calculate the vector sum " { $snippet "αx + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
-
-HELP: n*V
-{ $values { "alpha" "a number" } { "x" blas-vector-base } { "alpha*x" blas-vector-base } }
-{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
-
-HELP: V+
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x+y" blas-vector-base } }
-{ $description "Calculate the vector sum " { $snippet "x + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
-
-HELP: V-
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x-y" blas-vector-base } }
-{ $description "Calculate the vector difference " { $snippet "x – y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
-
-HELP: Vneg
-{ $values { "x" blas-vector-base } { "-x" blas-vector-base } }
-{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result." } ;
-
-HELP: V*n
-{ $values { "x" blas-vector-base } { "alpha" number } { "x*alpha" blas-vector-base } }
-{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
-
-HELP: V/n
-{ $values { "x" blas-vector-base } { "alpha" number } { "x/alpha" blas-vector-base } }
-{ $description "Calculate the scalar-vector product " { $snippet "(1/α)x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
-
-{ n*V+V! n*V! n*V+V n*V V+ V- Vneg V*n V/n } related-words
-
-HELP: Vsub
-{ $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } }
-{ $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ;
+++ /dev/null
-USING: kernel math.blas.vectors math.blas.syntax sequences tools.test ;
-IN: math.blas.vectors.tests
-
-! clone
-
-[ svector{ 1.0 2.0 3.0 } ] [ svector{ 1.0 2.0 3.0 } clone ] unit-test
-[ f ] [ svector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test
-[ dvector{ 1.0 2.0 3.0 } ] [ dvector{ 1.0 2.0 3.0 } clone ] unit-test
-[ f ] [ dvector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test
-[ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test
-[ f ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test
-[ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test
-[ f ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test
-
-! nth
-
-[ 1.0 ] [ 2 svector{ 3.0 2.0 1.0 } nth ] unit-test
-[ 1.0 ] [ 2 dvector{ 3.0 2.0 1.0 } nth ] unit-test
-
-[ C{ 1.0 2.0 } ]
-[ 2 cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test
-
-[ C{ 1.0 2.0 } ]
-[ 2 zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test
-
-! set-nth
-
-[ svector{ 3.0 2.0 0.0 } ] [ 0.0 2 svector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test
-[ dvector{ 3.0 2.0 0.0 } ] [ 0.0 2 dvector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test
-
-[ cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [
- C{ 3.0 4.0 } 2
- cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } }
- [ set-nth ] keep
-] unit-test
-[ zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [
- C{ 3.0 4.0 } 2
- zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } }
- [ set-nth ] keep
-] unit-test
-
-! V+
-
-[ svector{ 11.0 22.0 } ] [ svector{ 1.0 2.0 } svector{ 10.0 20.0 } V+ ] unit-test
-[ dvector{ 11.0 22.0 } ] [ dvector{ 1.0 2.0 } dvector{ 10.0 20.0 } V+ ] unit-test
-
-[ cvector{ 11.0 C{ 22.0 33.0 } } ]
-[ cvector{ 1.0 C{ 2.0 3.0 } } cvector{ 10.0 C{ 20.0 30.0 } } V+ ]
-unit-test
-
-[ zvector{ 11.0 C{ 22.0 33.0 } } ]
-[ zvector{ 1.0 C{ 2.0 3.0 } } zvector{ 10.0 C{ 20.0 30.0 } } V+ ]
-unit-test
-
-! V-
-
-[ svector{ 9.0 18.0 } ] [ svector{ 10.0 20.0 } svector{ 1.0 2.0 } V- ] unit-test
-[ dvector{ 9.0 18.0 } ] [ dvector{ 10.0 20.0 } dvector{ 1.0 2.0 } V- ] unit-test
-
-[ cvector{ 9.0 C{ 18.0 27.0 } } ]
-[ cvector{ 10.0 C{ 20.0 30.0 } } cvector{ 1.0 C{ 2.0 3.0 } } V- ]
-unit-test
-
-[ zvector{ 9.0 C{ 18.0 27.0 } } ]
-[ zvector{ 10.0 C{ 20.0 30.0 } } zvector{ 1.0 C{ 2.0 3.0 } } V- ]
-unit-test
-
-! Vneg
-
-[ svector{ 1.0 -2.0 } ] [ svector{ -1.0 2.0 } Vneg ] unit-test
-[ dvector{ 1.0 -2.0 } ] [ dvector{ -1.0 2.0 } Vneg ] unit-test
-
-[ cvector{ 1.0 C{ -2.0 3.0 } } ] [ cvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test
-[ zvector{ 1.0 C{ -2.0 3.0 } } ] [ zvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test
-
-! n*V
-
-[ svector{ 100.0 200.0 } ] [ 10.0 svector{ 10.0 20.0 } n*V ] unit-test
-[ dvector{ 100.0 200.0 } ] [ 10.0 dvector{ 10.0 20.0 } n*V ] unit-test
-
-[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
-[ C{ 10.0 2.0 } cvector{ 2.0 C{ 1.0 1.0 } } n*V ]
-unit-test
-
-[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
-[ C{ 10.0 2.0 } zvector{ 2.0 C{ 1.0 1.0 } } n*V ]
-unit-test
-
-! V*n
-
-[ svector{ 100.0 200.0 } ] [ svector{ 10.0 20.0 } 10.0 V*n ] unit-test
-[ dvector{ 100.0 200.0 } ] [ dvector{ 10.0 20.0 } 10.0 V*n ] unit-test
-
-[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
-[ cvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ]
-unit-test
-
-[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
-[ zvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ]
-unit-test
-
-! V/n
-
-[ svector{ 1.0 2.0 } ] [ svector{ 4.0 8.0 } 4.0 V/n ] unit-test
-[ dvector{ 1.0 2.0 } ] [ dvector{ 4.0 8.0 } 4.0 V/n ] unit-test
-
-[ cvector{ C{ 0.0 -4.0 } 1.0 } ]
-[ cvector{ C{ 4.0 -4.0 } C{ 1.0 1.0 } } C{ 1.0 1.0 } V/n ]
-unit-test
-
-[ zvector{ C{ 0.0 -4.0 } 1.0 } ]
-[ zvector{ C{ 4.0 -4.0 } C{ 1.0 1.0 } } C{ 1.0 1.0 } V/n ]
-unit-test
-
-! V.
-
-[ 7.0 ] [ svector{ 1.0 2.5 } svector{ 2.0 2.0 } V. ] unit-test
-[ 7.0 ] [ dvector{ 1.0 2.5 } dvector{ 2.0 2.0 } V. ] unit-test
-[ C{ 7.0 7.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test
-[ C{ 7.0 7.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test
-
-! V.conj
-
-[ C{ 7.0 3.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test
-[ C{ 7.0 3.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test
-
-! Vnorm
-
-[ 5.0 ] [ svector{ 3.0 4.0 } Vnorm ] unit-test
-[ 5.0 ] [ dvector{ 3.0 4.0 } Vnorm ] unit-test
-
-[ 13.0 ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test
-[ 13.0 ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test
-
-! Vasum
-
-[ 6.0 ] [ svector{ 1.0 2.0 -3.0 } Vasum ] unit-test
-[ 6.0 ] [ dvector{ 1.0 2.0 -3.0 } Vasum ] unit-test
-
-[ 15.0 ] [ cvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test
-[ 15.0 ] [ zvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test
-
-! Vswap
-
-[ svector{ 2.0 2.0 } svector{ 1.0 1.0 } ]
-[ svector{ 1.0 1.0 } svector{ 2.0 2.0 } Vswap ]
-unit-test
-
-[ dvector{ 2.0 2.0 } dvector{ 1.0 1.0 } ]
-[ dvector{ 1.0 1.0 } dvector{ 2.0 2.0 } Vswap ]
-unit-test
-
-[ cvector{ 2.0 C{ 2.0 2.0 } } cvector{ C{ 1.0 1.0 } 1.0 } ]
-[ cvector{ C{ 1.0 1.0 } 1.0 } cvector{ 2.0 C{ 2.0 2.0 } } Vswap ]
-unit-test
-
-[ zvector{ 2.0 C{ 2.0 2.0 } } zvector{ C{ 1.0 1.0 } 1.0 } ]
-[ zvector{ C{ 1.0 1.0 } 1.0 } zvector{ 2.0 C{ 2.0 2.0 } } Vswap ]
-unit-test
-
-! Viamax
-
-[ 3 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test
-[ 3 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test
-[ 0 ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test
-[ 0 ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test
-
-! Vamax
-
-[ -6.0 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test
-[ -6.0 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test
-[ C{ 2.0 -5.0 } ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test
-[ C{ 2.0 -5.0 } ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test
-
-! Vsub
-
-[ svector{ -5.0 4.0 -6.0 } ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test
-[ dvector{ -5.0 4.0 -6.0 } ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test
-[ cvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ cvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test
-[ zvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ zvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test
+++ /dev/null
-USING: accessors alien alien.c-types arrays byte-arrays combinators
-combinators.short-circuit fry kernel macros math math.blas.cblas
-math.complex math.functions math.order multi-methods qualified
-sequences sequences.private generalizations
-specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.float specialized-arrays.direct.double ;
-QUALIFIED: syntax
-IN: math.blas.vectors
-
-TUPLE: blas-vector-base data length inc ;
-TUPLE: float-blas-vector < blas-vector-base ;
-TUPLE: double-blas-vector < blas-vector-base ;
-TUPLE: float-complex-blas-vector < blas-vector-base ;
-TUPLE: double-complex-blas-vector < blas-vector-base ;
-
-INSTANCE: float-blas-vector sequence
-INSTANCE: double-blas-vector sequence
-INSTANCE: float-complex-blas-vector sequence
-INSTANCE: double-complex-blas-vector sequence
-
-C: <float-blas-vector> float-blas-vector
-C: <double-blas-vector> double-blas-vector
-C: <float-complex-blas-vector> float-complex-blas-vector
-C: <double-complex-blas-vector> double-complex-blas-vector
-
-GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y )
-GENERIC: n*V! ( alpha x -- x=alpha*x )
-
-GENERIC: V. ( x y -- x.y )
-GENERIC: V.conj ( x y -- xconj.y )
-GENERIC: Vnorm ( x -- norm )
-GENERIC: Vasum ( x -- sum )
-GENERIC: Vswap ( x y -- x=y y=x )
-
-GENERIC: Viamax ( x -- max-i )
-
-GENERIC: element-type ( v -- type )
-
-METHOD: element-type { float-blas-vector }
- drop "float" ;
-METHOD: element-type { double-blas-vector }
- drop "double" ;
-METHOD: element-type { float-complex-blas-vector }
- drop "CBLAS_C" ;
-METHOD: element-type { double-complex-blas-vector }
- drop "CBLAS_Z" ;
-
-<PRIVATE
-
-GENERIC: (blas-vector-like) ( data length inc exemplar -- vector )
-
-METHOD: (blas-vector-like) { object object object float-blas-vector }
- drop <float-blas-vector> ;
-METHOD: (blas-vector-like) { object object object double-blas-vector }
- drop <double-blas-vector> ;
-METHOD: (blas-vector-like) { object object object float-complex-blas-vector }
- drop <float-complex-blas-vector> ;
-METHOD: (blas-vector-like) { object object object double-complex-blas-vector }
- drop <double-complex-blas-vector> ;
-
-: (prepare-copy) ( v element-size -- length v-data v-inc v-dest-data v-dest-inc )
- [ [ length>> ] [ data>> ] [ inc>> ] tri ] dip
- 4 npick * <byte-array>
- 1 ;
-
-MACRO: (do-copy) ( copy make-vector -- )
- '[ over 6 npick _ 2dip 1 @ ] ;
-
-: (prepare-swap) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc v1 v2 )
- [
- [ [ length>> ] bi@ min ]
- [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
- ] 2keep ;
-
-: (prepare-axpy) ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc v2 )
- [
- [ [ length>> ] bi@ min swap ]
- [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
- ] keep ;
-
-: (prepare-scal) ( n v -- length n v-data v-inc v )
- [ [ length>> swap ] [ data>> ] [ inc>> ] tri ] keep ;
-
-: (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc )
- [ [ length>> ] bi@ min ]
- [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi ;
-
-: (prepare-nrm2) ( v -- length v1-data v1-inc )
- [ length>> ] [ data>> ] [ inc>> ] tri ;
-
-: (flatten-complex-sequence) ( seq -- seq' )
- [ [ real-part ] [ imaginary-part ] bi 2array ] map concat ;
-
-: (>c-complex) ( complex -- alien )
- [ real-part ] [ imaginary-part ] bi float-array{ } 2sequence underlying>> ;
-: (>z-complex) ( complex -- alien )
- [ real-part ] [ imaginary-part ] bi double-array{ } 2sequence underlying>> ;
-
-: (c-complex>) ( alien -- complex )
- 2 <direct-float-array> first2 rect> ;
-: (z-complex>) ( alien -- complex )
- 2 <direct-double-array> first2 rect> ;
-
-: (prepare-nth) ( n v -- n*inc v-data )
- [ inc>> ] [ data>> ] bi [ * ] dip ;
-
-MACRO: (complex-nth) ( nth-quot -- )
- '[
- [ 2 * dup 1+ ] dip
- _ curry bi@ rect>
- ] ;
-
-: (c-complex-nth) ( n alien -- complex )
- [ float-nth ] (complex-nth) ;
-: (z-complex-nth) ( n alien -- complex )
- [ double-nth ] (complex-nth) ;
-
-MACRO: (set-complex-nth) ( set-nth-quot -- )
- '[
- [
- [ [ real-part ] [ imaginary-part ] bi ]
- [ 2 * dup 1+ ] bi*
- swapd
- ] dip
- _ curry 2bi@
- ] ;
-
-: (set-c-complex-nth) ( complex n alien -- )
- [ set-float-nth ] (set-complex-nth) ;
-: (set-z-complex-nth) ( complex n alien -- )
- [ set-double-nth ] (set-complex-nth) ;
-
-PRIVATE>
-
-: <zero-vector> ( exemplar -- zero )
- [ element-type <c-object> ]
- [ length>> 0 ]
- [ (blas-vector-like) ] tri ;
-
-: <empty-vector> ( length exemplar -- vector )
- [ element-type <c-array> ]
- [ 1 swap ] 2bi
- (blas-vector-like) ;
-
-syntax:M: blas-vector-base length
- length>> ;
-
-syntax:M: float-blas-vector nth-unsafe
- (prepare-nth) float-nth ;
-syntax:M: float-blas-vector set-nth-unsafe
- (prepare-nth) set-float-nth ;
-
-syntax:M: double-blas-vector nth-unsafe
- (prepare-nth) double-nth ;
-syntax:M: double-blas-vector set-nth-unsafe
- (prepare-nth) set-double-nth ;
-
-syntax:M: float-complex-blas-vector nth-unsafe
- (prepare-nth) (c-complex-nth) ;
-syntax:M: float-complex-blas-vector set-nth-unsafe
- (prepare-nth) (set-c-complex-nth) ;
-
-syntax:M: double-complex-blas-vector nth-unsafe
- (prepare-nth) (z-complex-nth) ;
-syntax:M: double-complex-blas-vector set-nth-unsafe
- (prepare-nth) (set-z-complex-nth) ;
-
-syntax:M: blas-vector-base equal?
- {
- [ [ length ] bi@ = ]
- [ [ = ] 2all? ]
- } 2&& ;
-
-: >float-blas-vector ( seq -- v )
- [ >float-array underlying>> ] [ length ] bi 1 <float-blas-vector> ;
-: >double-blas-vector ( seq -- v )
- [ >double-array underlying>> ] [ length ] bi 1 <double-blas-vector> ;
-: >float-complex-blas-vector ( seq -- v )
- [ (flatten-complex-sequence) >float-array underlying>> ] [ length ] bi
- 1 <float-complex-blas-vector> ;
-: >double-complex-blas-vector ( seq -- v )
- [ (flatten-complex-sequence) >double-array underlying>> ] [ length ] bi
- 1 <double-complex-blas-vector> ;
-
-syntax:M: float-blas-vector clone
- "float" heap-size (prepare-copy)
- [ cblas_scopy ] [ <float-blas-vector> ] (do-copy) ;
-syntax:M: double-blas-vector clone
- "double" heap-size (prepare-copy)
- [ cblas_dcopy ] [ <double-blas-vector> ] (do-copy) ;
-syntax:M: float-complex-blas-vector clone
- "CBLAS_C" heap-size (prepare-copy)
- [ cblas_ccopy ] [ <float-complex-blas-vector> ] (do-copy) ;
-syntax:M: double-complex-blas-vector clone
- "CBLAS_Z" heap-size (prepare-copy)
- [ cblas_zcopy ] [ <double-complex-blas-vector> ] (do-copy) ;
-
-METHOD: Vswap { float-blas-vector float-blas-vector }
- (prepare-swap) [ cblas_sswap ] 2dip ;
-METHOD: Vswap { double-blas-vector double-blas-vector }
- (prepare-swap) [ cblas_dswap ] 2dip ;
-METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector }
- (prepare-swap) [ cblas_cswap ] 2dip ;
-METHOD: Vswap { double-complex-blas-vector double-complex-blas-vector }
- (prepare-swap) [ cblas_zswap ] 2dip ;
-
-METHOD: n*V+V! { real float-blas-vector float-blas-vector }
- (prepare-axpy) [ cblas_saxpy ] dip ;
-METHOD: n*V+V! { real double-blas-vector double-blas-vector }
- (prepare-axpy) [ cblas_daxpy ] dip ;
-METHOD: n*V+V! { number float-complex-blas-vector float-complex-blas-vector }
- [ (>c-complex) ] 2dip
- (prepare-axpy) [ cblas_caxpy ] dip ;
-METHOD: n*V+V! { number double-complex-blas-vector double-complex-blas-vector }
- [ (>z-complex) ] 2dip
- (prepare-axpy) [ cblas_zaxpy ] dip ;
-
-METHOD: n*V! { real float-blas-vector }
- (prepare-scal) [ cblas_sscal ] dip ;
-METHOD: n*V! { real double-blas-vector }
- (prepare-scal) [ cblas_dscal ] dip ;
-METHOD: n*V! { number float-complex-blas-vector }
- [ (>c-complex) ] dip
- (prepare-scal) [ cblas_cscal ] dip ;
-METHOD: n*V! { number double-complex-blas-vector }
- [ (>z-complex) ] dip
- (prepare-scal) [ cblas_zscal ] dip ;
-
-: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
-: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
-
-: V+ ( x y -- x+y )
- 1.0 -rot n*V+V ; inline
-: V- ( x y -- x-y )
- -1.0 spin n*V+V ; inline
-
-: Vneg ( x -- -x )
- -1.0 swap n*V ; inline
-
-: V*n ( x alpha -- x*alpha )
- swap n*V ; inline
-: V/n ( x alpha -- x/alpha )
- recip swap n*V ; inline
-
-METHOD: V. { float-blas-vector float-blas-vector }
- (prepare-dot) cblas_sdot ;
-METHOD: V. { double-blas-vector double-blas-vector }
- (prepare-dot) cblas_ddot ;
-METHOD: V. { float-complex-blas-vector float-complex-blas-vector }
- (prepare-dot)
- "CBLAS_C" <c-object> [ cblas_cdotu_sub ] keep (c-complex>) ;
-METHOD: V. { double-complex-blas-vector double-complex-blas-vector }
- (prepare-dot)
- "CBLAS_Z" <c-object> [ cblas_zdotu_sub ] keep (z-complex>) ;
-
-METHOD: V.conj { float-blas-vector float-blas-vector }
- (prepare-dot) cblas_sdot ;
-METHOD: V.conj { double-blas-vector double-blas-vector }
- (prepare-dot) cblas_ddot ;
-METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector }
- (prepare-dot)
- "CBLAS_C" <c-object> [ cblas_cdotc_sub ] keep (c-complex>) ;
-METHOD: V.conj { double-complex-blas-vector double-complex-blas-vector }
- (prepare-dot)
- "CBLAS_Z" <c-object> [ cblas_zdotc_sub ] keep (z-complex>) ;
-
-METHOD: Vnorm { float-blas-vector }
- (prepare-nrm2) cblas_snrm2 ;
-METHOD: Vnorm { double-blas-vector }
- (prepare-nrm2) cblas_dnrm2 ;
-METHOD: Vnorm { float-complex-blas-vector }
- (prepare-nrm2) cblas_scnrm2 ;
-METHOD: Vnorm { double-complex-blas-vector }
- (prepare-nrm2) cblas_dznrm2 ;
-
-METHOD: Vasum { float-blas-vector }
- (prepare-nrm2) cblas_sasum ;
-METHOD: Vasum { double-blas-vector }
- (prepare-nrm2) cblas_dasum ;
-METHOD: Vasum { float-complex-blas-vector }
- (prepare-nrm2) cblas_scasum ;
-METHOD: Vasum { double-complex-blas-vector }
- (prepare-nrm2) cblas_dzasum ;
-
-METHOD: Viamax { float-blas-vector }
- (prepare-nrm2) cblas_isamax ;
-METHOD: Viamax { double-blas-vector }
- (prepare-nrm2) cblas_idamax ;
-METHOD: Viamax { float-complex-blas-vector }
- (prepare-nrm2) cblas_icamax ;
-METHOD: Viamax { double-complex-blas-vector }
- (prepare-nrm2) cblas_izamax ;
-
-: Vamax ( x -- max )
- [ Viamax ] keep nth ; inline
-
-: Vsub ( v start length -- sub )
- rot [
- [
- nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri
- [ * * ] dip <displaced-alien>
- ] [ swap 2nip ] [ 2nip inc>> ] 3tri
- ] keep (blas-vector-like) ;
+++ /dev/null
-Slava Pestov
-Doug Coleman
-Aaron Schaefer
+++ /dev/null
-USING: help.markup help.syntax kernel math math.order sequences ;
-IN: math.combinatorics
-
-HELP: factorial
-{ $values { "n" "a non-negative integer" } { "n!" integer } }
-{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ;
-
-HELP: nPk
-{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
-{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ;
-
-HELP: nCk
-{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
-{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ;
-
-HELP: permutation
-{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
-{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
-{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ;
-
-HELP: all-permutations
-{ $values { "seq" sequence } { "seq" sequence } }
-{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
-
-HELP: inverse-permutation
-{ $values { "seq" sequence } { "permutation" sequence } }
-{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
-{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
-
-
-IN: math.combinatorics.private
-
-HELP: factoradic
-{ $values { "n" integer } { "factoradic" sequence } }
-{ $description "Converts a positive integer " { $snippet "n" } " to factoradic form. The factoradic of an integer is its representation based on a mixed radix numerical system that corresponds to the values of " { $snippet "n" } " factorial." }
-{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ;
-
-HELP: >permutation
-{ $values { "factoradic" sequence } { "permutation" sequence } }
-{ $description "Converts an integer represented in factoradic form into its corresponding unique permutation (0-based)." }
-{ $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } }
-{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ;
-
+++ /dev/null
-USING: math.combinatorics math.combinatorics.private tools.test ;
-IN: math.combinatorics.tests
-
-[ { } ] [ 0 factoradic ] unit-test
-[ { 1 0 } ] [ 1 factoradic ] unit-test
-[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
-
-[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
-[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
-[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
-
-[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
-[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
-[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
-
-[ 1 ] [ 0 factorial ] unit-test
-[ 1 ] [ 1 factorial ] unit-test
-[ 3628800 ] [ 10 factorial ] unit-test
-
-[ 1 ] [ 3 0 nPk ] unit-test
-[ 6 ] [ 3 2 nPk ] unit-test
-[ 6 ] [ 3 3 nPk ] unit-test
-[ 0 ] [ 3 4 nPk ] unit-test
-[ 311875200 ] [ 52 5 nPk ] unit-test
-[ 672151459757865654763838640470031391460745878674027315200000000000 ] [ 52 47 nPk ] unit-test
-
-[ 1 ] [ 3 0 nCk ] unit-test
-[ 3 ] [ 3 2 nCk ] unit-test
-[ 1 ] [ 3 3 nCk ] unit-test
-[ 0 ] [ 3 4 nCk ] unit-test
-[ 2598960 ] [ 52 5 nCk ] unit-test
-[ 2598960 ] [ 52 47 nCk ] unit-test
-
-[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
-[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
-[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test
-
-[ { { "a" "b" "c" } { "a" "c" "b" }
- { "b" "a" "c" } { "b" "c" "a" }
- { "c" "a" "b" } { "c" "b" "a" } } ] [ { "a" "b" "c" } all-permutations ] unit-test
-
-[ { 0 1 2 } ] [ { "a" "b" "c" } inverse-permutation ] unit-test
-[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
-[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test
-
+++ /dev/null
-! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel math math.order math.ranges mirrors
-namespaces sequences sorting fry ;
-IN: math.combinatorics
-
-<PRIVATE
-
-: possible? ( n m -- ? )
- 0 rot between? ; inline
-
-: twiddle ( n k -- n k )
- 2dup - dupd > [ dupd - ] when ; inline
-
-! See this article for explanation of the factoradic-based permutation methodology:
-! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
-
-: factoradic ( n -- factoradic )
- 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
-
-: (>permutation) ( seq n -- seq )
- [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
-
-: >permutation ( factoradic -- permutation )
- reverse 1 cut [ (>permutation) ] each ;
-
-: permutation-indices ( n seq -- permutation )
- length [ factoradic ] dip 0 pad-left >permutation ;
-
-PRIVATE>
-
-: factorial ( n -- n! )
- 1 [ 1+ * ] reduce ;
-
-: nPk ( n k -- nPk )
- 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
-
-: nCk ( n k -- nCk )
- twiddle [ nPk ] keep factorial / ;
-
-: permutation ( n seq -- seq )
- [ permutation-indices ] keep nths ;
-
-: all-permutations ( seq -- seq )
- [ length factorial ] keep '[ _ permutation ] map ;
-
-: each-permutation ( seq quot -- )
- [ [ length factorial ] keep ] dip
- '[ _ permutation @ ] each ; inline
-
-: reduce-permutations ( seq initial quot -- result )
- swapd each-permutation ; inline
-
-: inverse-permutation ( seq -- permutation )
- <enum> >alist sort-values keys ;
+++ /dev/null
-Permutations and combinations
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: help.markup help.syntax math sequences ;
-IN: math.polynomials
-
-ARTICLE: "polynomials" "Polynomials"
-"A polynomial is a vector with the highest powers on the right:"
-{ $code "{ 1 1 0 1 } -> 1 + x + x^3" "{ } -> 0" }
-"Numerous words are defined to help with polynomial arithmetic:"
-{ $subsection p= }
-{ $subsection p+ }
-{ $subsection p- }
-{ $subsection p* }
-{ $subsection p-sq }
-{ $subsection powers }
-{ $subsection n*p }
-{ $subsection p/mod }
-{ $subsection pgcd }
-{ $subsection polyval }
-{ $subsection pdiff }
-{ $subsection pextend-conv }
-{ $subsection ptrim }
-{ $subsection 2ptrim } ;
-
-ABOUT: "polynomials"
-
-HELP: powers
-{ $values { "n" integer } { "x" number } { "seq" sequence } }
-{ $description "Output a sequence having " { $snippet "n" } " elements in the format: " { $snippet "{ 1 x x^2 x^3 ... }" } "." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "4 2 powers ." "{ 1 2 4 8 }" } } ;
-
-HELP: p=
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "?" "a boolean" } }
-{ $description "Tests if two polynomials are equal." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 } { 0 1 0 } p= ." "t" } } ;
-
-HELP: ptrim
-{ $values { "p" "a polynomial" } { "p" "a polynomial" } }
-{ $description "Trims excess zeros from a polynomial." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 0 0 } ptrim ." "{ 0 1 }" } } ;
-
-HELP: 2ptrim
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
-{ $description "Trims excess zeros from two polynomials." }
-{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim [ . ] bi@" "{ 0 1 }\n{ 1 }" } } ;
-
-HELP: p+
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
-{ $description "Adds " { $snippet "p" } " and " { $snippet "q" } " component-wise." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } p+ ." "{ 1 1 1 }" } } ;
-
-HELP: p-
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
-{ $description "Subtracts " { $snippet "q" } " from " { $snippet "p" } " component-wise." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 } { 0 1 } p- ." "{ 1 0 1 }" } } ;
-
-HELP: n*p
-{ $values { "n" number } { "p" "a polynomial" } { "n*p" "a polynomial" } }
-{ $description "Multiplies each element of " { $snippet "p" } " by " { $snippet "n" } "." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "4 { 3 0 1 } n*p ." "{ 12 0 4 }" } } ;
-
-HELP: pextend-conv
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
-{ $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." }
-{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ;
-
-HELP: p*
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
-{ $description "Multiplies two polynomials." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 3 0 0 0 } { 1 2 0 0 } p* ." "{ 1 4 7 6 0 0 0 0 0 }" } } ;
-
-HELP: p-sq
-{ $values { "p" "a polynomial" } { "p^2" "a polynomial" } }
-{ $description "Squares a polynomial." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 0 } p-sq ." "{ 1 4 4 0 0 }" } } ;
-
-HELP: p/mod
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } }
-{ $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." }
-{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 1 1 1 } { 3 1 } p/mod [ . ] bi@" "V{ 7 -2 1 }\nV{ -20 0 0 }" } } ;
-
-HELP: pgcd
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "a" "a polynomial" } { "d" "a polynomial" } }
-{ $description "Computes the greatest common divisor " { $snippet "d" } " of " { $snippet "p" } " and " { $snippet "q" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*q = d mod p" } }
-{ $notes "GCD in the case of polynomials is a monic polynomial of the highest possible degree that divides into both " { $snippet "p" } " and " { $snippet "q" } "." }
-{ $examples
- { $example "USING: kernel math.polynomials prettyprint ;"
- "{ 1 1 1 1 } { 1 1 } pgcd [ . ] bi@"
- "{ 0 0 }\n{ 1 1 }"
- }
-} ;
-
-HELP: pdiff
-{ $values { "p" "a polynomial" } { "p'" "a polynomial" } }
-{ $description "Finds the derivative of " { $snippet "p" } "." } ;
-
-HELP: polyval
-{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } }
-{ $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ;
-
+++ /dev/null
-USING: kernel math math.polynomials tools.test ;
-IN: math.polynomials.tests
-
-[ { 0 1 } ] [ { 0 1 0 0 } ptrim ] unit-test
-[ { 1 } ] [ { 1 0 0 } ptrim ] unit-test
-[ { 0 } ] [ { 0 } ptrim ] unit-test
-[ { 3 10 8 } ] [ { 1 2 } { 3 4 } p* ] unit-test
-[ { 3 10 8 } ] [ { 3 4 } { 1 2 } p* ] unit-test
-[ { 0 0 0 0 0 0 0 0 0 0 } ] [ { 0 0 0 } { 0 0 0 0 0 0 0 0 } p* ] unit-test
-[ { 0 1 } ] [ { 0 1 } { 1 } p* ] unit-test
-[ { 0 } ] [ { } { } p* ] unit-test
-[ { 0 } ] [ { 0 } { } p* ] unit-test
-[ { 0 } ] [ { } { 0 } p* ] unit-test
-[ { 0 0 0 } ] [ { 0 0 0 } { 0 0 0 } p+ ] unit-test
-[ { 0 0 0 } ] [ { 0 0 0 } { 0 0 0 } p- ] unit-test
-[ { 0 0 0 } ] [ 4 { 0 0 0 } n*p ] unit-test
-[ { 4 8 0 12 } ] [ 4 { 1 2 0 3 } n*p ] unit-test
-[ { 1 4 7 6 0 0 0 0 0 } ] [ { 1 2 3 0 0 0 } { 1 2 0 0 } p* ] unit-test
-[ V{ 7 -2 1 } V{ -20 0 0 } ] [ { 1 1 1 1 } { 3 1 } p/mod ] unit-test
-[ V{ 0 0 } V{ 1 1 } ] [ { 1 1 } { 1 1 1 1 } p/mod ] unit-test
-[ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 } { 1 1 } p/mod ] unit-test
-[ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 } { 1 1 0 0 0 0 0 0 } p/mod ] unit-test
-[ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 0 0 0 0 } { 1 1 0 0 } p/mod ] unit-test
-[ V{ 5.0 } V{ 0 } ] [ { 10.0 } { 2.0 } p/mod ] unit-test
-[ V{ 15/16 } V{ 0 } ] [ { 3/4 } { 4/5 } p/mod ] unit-test
-[ t ] [ { 0 1 } { 0 1 0 } p= ] unit-test
-[ f ] [ { 0 0 1 } { 0 1 0 } p= ] unit-test
-[ t ] [ { 1 1 1 } { 1 1 1 } p= ] unit-test
-[ { 0 0 } { 1 1 } ] [ { 1 1 1 1 } { 1 1 } pgcd ] unit-test
-
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel make math math.order math.vectors sequences shuffle
- splitting vectors ;
-IN: math.polynomials
-
-<PRIVATE
-
-: 2pad-left ( p q n -- p q ) [ 0 pad-left ] curry bi@ ;
-: 2pad-right ( p q n -- p q ) [ 0 pad-right ] curry bi@ ;
-: pextend ( p q -- p q ) 2dup [ length ] bi@ max 2pad-right ;
-: pextend-left ( p q -- p q ) 2dup [ length ] bi@ max 2pad-left ;
-: unempty ( seq -- seq ) [ { 0 } ] when-empty ;
-: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
-
-PRIVATE>
-
-: powers ( n x -- seq )
- <array> 1 [ * ] accumulate nip ;
-
-: p= ( p q -- ? ) pextend = ;
-
-: ptrim ( p -- p )
- dup length 1 = [ [ zero? ] trim-right ] unless ;
-
-: 2ptrim ( p q -- p q ) [ ptrim ] bi@ ;
-: p+ ( p q -- r ) pextend v+ ;
-: p- ( p q -- r ) pextend v- ;
-: n*p ( n p -- n*p ) n*v ;
-
-: pextend-conv ( p q -- p q )
- 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
-
-: p* ( p q -- r )
- 2unempty pextend-conv <reversed> dup length
- [ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
-
-: p-sq ( p -- p^2 )
- dup p* ;
-
-<PRIVATE
-
-: p/mod-setup ( p p -- p p n )
- 2ptrim
- 2dup [ length ] bi@ -
- dup 1 < [ drop 1 ] when
- [ over length + 0 pad-left pextend ] keep 1+ ;
-
-: /-last ( seq seq -- a )
- #! divide the last two numbers in the sequences
- [ peek ] bi@ / ;
-
-: (p/mod) ( p p -- p p )
- 2dup /-last
- 2dup , n*p swapd
- p- >vector
- dup pop* swap rest-slice ;
-
-PRIVATE>
-
-: p/mod ( p q -- z w )
- p/mod-setup [ [ (p/mod) ] times ] V{ } make
- reverse nip swap 2ptrim pextend ;
-
-<PRIVATE
-
-: (pgcd) ( b a y x -- a d )
- dup V{ 0 } clone p= [
- drop nip
- ] [
- tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
- ] if ;
-
-PRIVATE>
-
-: pgcd ( p q -- a d )
- swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ;
-
-: pdiff ( p -- p' )
- dup length v* { 0 } ?head drop ;
-
-: polyval ( p x -- p[x] )
- [ dup length ] dip powers v. ;
-
+++ /dev/null
-Polynomial arithmetic
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax math math.vectors vectors ;
-IN: math.quaternions
-
-HELP: q*
-{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } }
-{ $description "Multiply quaternions." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q* ." "{ 0 C{ 0 1 } }" } } ;
-
-HELP: qconjugate
-{ $values { "u" "a quaternion" } { "u'" "a quaternion" } }
-{ $description "Quaternion conjugate." } ;
-
-HELP: qrecip
-{ $values { "u" "a quaternion" } { "1/u" "a quaternion" } }
-{ $description "Quaternion inverse." } ;
-
-HELP: q/
-{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u/v" "a quaternion" } }
-{ $description "Divide quaternions." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 C{ 0 1 } } { 0 1 } q/ ." "{ C{ 0 1 } 0 }" } } ;
-
-HELP: q*n
-{ $values { "q" "a quaternion" } { "n" number } { "q" "a quaternion" } }
-{ $description "Multiplies each element of " { $snippet "q" } " by " { $snippet "n" } "." }
-{ $notes "You will get the wrong result if you try to multiply a quaternion by a complex number on the right using " { $link v*n } ". Use this word instead."
- $nl "Note that " { $link v*n } " with a quaternion and a real is okay." } ;
-
-HELP: c>q
-{ $values { "c" number } { "q" "a quaternion" } }
-{ $description "Turn a complex number into a quaternion." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "C{ 0 1 } c>q ." "{ C{ 0 1 } 0 }" } } ;
-
-HELP: v>q
-{ $values { "v" vector } { "q" "a quaternion" } }
-{ $description "Turn a 3-vector into a quaternion with real part 0." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 1 0 0 } v>q ." "{ C{ 0 1 } 0 }" } } ;
-
-HELP: q>v
-{ $values { "q" "a quaternion" } { "v" vector } }
-{ $description "Get the vector part of a quaternion, discarding the real part." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } q>v ." "{ 1 0 0 }" } } ;
-
-HELP: euler
-{ $values { "phi" number } { "theta" number } { "psi" number } { "q" "a quaternion" } }
-{ $description "Convert a rotation given by Euler angles (phi, theta, and psi) to a quaternion." } ;
-
+++ /dev/null
-IN: math.quaternions.tests
-USING: tools.test math.quaternions kernel math.vectors
-math.constants ;
-
-[ 1.0 ] [ qi norm ] unit-test
-[ 1.0 ] [ qj norm ] unit-test
-[ 1.0 ] [ qk norm ] unit-test
-[ 1.0 ] [ q1 norm ] unit-test
-[ 0.0 ] [ q0 norm ] unit-test
-[ t ] [ qi qj q* qk = ] unit-test
-[ t ] [ qj qk q* qi = ] unit-test
-[ t ] [ qk qi q* qj = ] unit-test
-[ t ] [ qi qi q* q1 v+ q0 = ] unit-test
-[ t ] [ qj qj q* q1 v+ q0 = ] unit-test
-[ t ] [ qk qk q* q1 v+ q0 = ] unit-test
-[ t ] [ qi qj qk q* q* q1 v+ q0 = ] unit-test
-[ t ] [ C{ 0 1 } qj n*v qk = ] unit-test
-[ t ] [ qj C{ 0 1 } q*n qk v+ q0 = ] unit-test
-[ t ] [ qk qj q/ qi = ] unit-test
-[ t ] [ qi qk q/ qj = ] unit-test
-[ t ] [ qj qi q/ qk = ] unit-test
-[ t ] [ qi q>v v>q qi = ] unit-test
-[ t ] [ qj q>v v>q qj = ] unit-test
-[ t ] [ qk q>v v>q qk = ] unit-test
-[ t ] [ 1 c>q q1 = ] unit-test
-[ t ] [ C{ 0 1 } c>q qi = ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions math.vectors sequences ;
-IN: math.quaternions
-
-! Everybody's favorite non-commutative skew field, the quaternions!
-
-! Quaternions are represented as pairs of complex numbers, using the
-! identity: (a+bi)+(c+di)j = a+bi+cj+dk.
-
-<PRIVATE
-
-: ** conjugate * ; inline
-
-: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
-
-: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline
-
-: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline
-
-PRIVATE>
-
-: q* ( u v -- u*v )
- [ q*a ] [ q*b ] 2bi 2array ;
-
-: qconjugate ( u -- u' )
- first2 [ conjugate ] [ neg ] bi* 2array ;
-
-: qrecip ( u -- 1/u )
- qconjugate dup norm-sq v/n ;
-
-: q/ ( u v -- u/v )
- qrecip q* ;
-
-: q*n ( q n -- q )
- conjugate v*n ;
-
-: c>q ( c -- q )
- 0 2array ;
-
-: v>q ( v -- q )
- first3 rect> [ 0 swap rect> ] dip 2array ;
-
-: q>v ( q -- v )
- first2 [ imaginary-part ] dip >rect 3array ;
-
-! Zero
-: q0 { 0 0 } ;
-
-! Units
-: q1 { 1 0 } ;
-: qi { C{ 0 1 } 0 } ;
-: qj { 0 1 } ;
-: qk { 0 C{ 0 1 } } ;
-
-! Euler angles
-
-<PRIVATE
-
-: (euler) ( theta unit -- q )
- [ -0.5 * [ cos c>q ] [ sin ] bi ] dip n*v v- ;
-
-PRIVATE>
-
-: euler ( phi theta psi -- q )
- [ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ;
+++ /dev/null
-Quaternion arithmetic and Euler angles
+++ /dev/null
-Doug Coleman
-Michael Judge
+++ /dev/null
-USING: help.markup help.syntax debugger ;
-IN: math.statistics
-
-HELP: geometric-mean
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
-{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
-{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
-{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
-
-HELP: harmonic-mean
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
-{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
-{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } }
-{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
-
-HELP: mean
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
-{ $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." }
-{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } }
-{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
-
-HELP: median
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
-{ $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." }
-{ $examples
- { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" }
- { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } median ." "2+1/2" } }
-{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
-
-HELP: range
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
-{ $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" }
- { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } range ." "3" } } ;
-
-HELP: std
-{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
-{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." }
-{ $examples
- { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" }
- { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;
-
-HELP: ste
- { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
- { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." }
- { $examples
- { $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" }
- { $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ;
-
-HELP: var
-{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
-{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." }
-{ $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." }
-{ $examples
- { $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" }
- { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } var ." "1" }
- { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } var ." "1+2/3" } } ;
-
+++ /dev/null
-USING: kernel math math.functions math.statistics tools.test ;
-IN: math.statistics.tests
-
-[ 1 ] [ { 1 } mean ] unit-test
-[ 3/2 ] [ { 1 2 } mean ] unit-test
-[ 0 ] [ { 0 0 0 } geometric-mean ] unit-test
-[ t ] [ { 2 2 2 2 } geometric-mean 2.0 .0001 ~ ] unit-test
-[ 1.0 ] [ { 1 1 1 } geometric-mean ] unit-test
-[ 1/3 ] [ { 1 1 1 } harmonic-mean ] unit-test
-
-[ 0 ] [ { 1 } range ] unit-test
-[ 89 ] [ { 1 2 30 90 } range ] unit-test
-[ 2 ] [ { 1 2 3 } median ] unit-test
-[ 5/2 ] [ { 1 2 3 4 } median ] unit-test
-
-[ 1 ] [ { 1 2 3 } var ] unit-test
-[ 1.0 ] [ { 1 2 3 } std ] unit-test
-[ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test
-
-[ t ] [ { 23.2 33.4 22.5 66.3 44.5 } std 18.1906 - .0001 < ] unit-test
-
-[ 0 ] [ { 1 } var ] unit-test
-[ 0.0 ] [ { 1 } std ] unit-test
-[ 0.0 ] [ { 1 } ste ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman, Michael Judge.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel math math.analysis math.functions sequences
- sequences.lib sorting ;
-IN: math.statistics
-
-: mean ( seq -- n )
- #! arithmetic mean, sum divided by length
- [ sum ] [ length ] bi / ;
-
-: geometric-mean ( seq -- n )
- #! geometric mean, nth root of product
- [ length ] [ product ] bi nth-root ;
-
-: harmonic-mean ( seq -- n )
- #! harmonic mean, reciprocal of sum of reciprocals.
- #! positive reals only
- [ recip ] sigma recip ;
-
-: median ( seq -- n )
- #! middle number if odd, avg of two middle numbers if even
- natural-sort dup length even? [
- [ midpoint@ dup 1- 2array ] keep nths mean
- ] [
- [ midpoint@ ] keep nth
- ] if ;
-
-: range ( seq -- n )
- #! max - min
- minmax swap - ;
-
-: var ( seq -- x )
- #! variance, normalize by N-1
- dup length 1 <= [
- drop 0
- ] [
- [ [ mean ] keep [ - sq ] with sigma ] keep
- length 1- /
- ] if ;
-
-: std ( seq -- x )
- #! standard deviation, sqrt of variance
- var sqrt ;
-
-: ste ( seq -- x )
- #! standard error, standard deviation / sqrt ( length of sequence )
- [ std ] [ length ] bi sqrt / ;
-
-: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
- ! finds sigma((xi-mean(x))(yi-mean(y))
- 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
-
-: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
- * recip [ [ ((r)) ] keep length 1- / ] dip * ;
-
-: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
- first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
-
-: r ( {{x,y}...} -- r )
- [r] (r) ;
-
-: r^2 ( {{x,y}...} -- r )
- r sq ;
-
-: least-squares ( {{x,y}...} -- alpha beta )
- [r] { [ 2dup ] [ ] [ ] [ ] [ ] } spread
- ! stack is mean(x) mean(y) mean(x) mean(y) {x} {y} sx sy
- [ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy
- swap / * ! stack is mean(x) mean(y) beta
- [ swapd * - ] keep ;
-
+++ /dev/null
-Mean, median, standard deviation, and other statistical routines
[ 4613732 ] [ euler002 ] unit-test
[ 4613732 ] [ euler002a ] unit-test
+[ 4613732 ] [ euler002b ] unit-test
-! Copyright (c) 2007 Aaron Schaefer, Alexander Solovyov.
+! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences shuffle ;
IN: project-euler.002
! [ euler002a ] 100 ave-time
! 0 ms ave run time - 0.2 SD (100 trials)
-MAIN: euler002a
+
+<PRIVATE
+
+: next-fibs ( x y -- y x+y )
+ tuck + ;
+
+: ?retotal ( total fib- fib+ -- retotal fib- fib+ )
+ dup even? [ [ nip + ] 2keep ] when ;
+
+: (sum-even-fibs-below) ( partial fib- fib+ max -- total )
+ 2dup > [
+ 3drop
+ ] [
+ [ ?retotal next-fibs ] dip (sum-even-fibs-below)
+ ] if ;
+
+PRIVATE>
+
+: sum-even-fibs-below ( max -- sum )
+ [ 0 0 1 ] dip (sum-even-fibs-below) ;
+
+: euler002b ( -- answer )
+ 4000000 sum-even-fibs-below ;
+
+! [ euler002b ] 100 ave-time
+! 0 ms ave run time - 0.0 SD (100 trials)
+
+MAIN: euler002b
--- /dev/null
+USING: project-euler.050 project-euler.050.private tools.test ;
+IN: project-euler.050.tests
+
+[ 41 ] [ 100 solve ] unit-test
+[ 953 ] [ 1000 solve ] unit-test
+[ 997651 ] [ euler050 ] unit-test
--- /dev/null
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel locals math math.primes sequences ;
+IN: project-euler.050
+
+! http://projecteuler.net/index.php?section=problems&id=50
+
+! DESCRIPTION
+! -----------
+
+! The prime 41, can be written as the sum of six consecutive primes:
+
+! 41 = 2 + 3 + 5 + 7 + 11 + 13
+
+! This is the longest sum of consecutive primes that adds to a prime below
+! one-hundred.
+
+! The longest sum of consecutive primes below one-thousand that adds to a
+! prime, contains 21 terms, and is equal to 953.
+
+! Which prime, below one-million, can be written as the sum of the most
+! consecutive primes?
+
+
+! SOLUTION
+! --------
+
+! 1) Create an sequence of all primes under 1000000.
+! 2) Start summing elements in the sequence until the next number would put you
+! over 1000000.
+! 3) Check if that sum is prime, if not, subtract the last number added.
+! 4) Repeat step 3 until you get a prime number, and store it along with the
+! how many consecutive numbers from the original sequence it took to get there.
+! 5) Drop the first number from the sequence of primes, and do steps 2-4 again
+! 6) Compare the longest chain from the first run with the second run, and store
+! the longer of the two.
+! 7) If the sequence of primes is still longer than the longest chain, then
+! repeat steps 5-7...otherwise, you've found the longest sum of consecutive
+! primes!
+
+<PRIVATE
+
+:: sum-upto ( seq limit -- length sum )
+ 0 seq [ + dup limit > ] find
+ [ swapd - ] [ drop seq length swap ] if* ;
+
+: pop-until-prime ( seq sum -- seq prime )
+ over length 0 > [
+ [ unclip-last-slice ] dip swap -
+ dup prime? [ pop-until-prime ] unless
+ ] [
+ 2drop { } 0
+ ] if ;
+
+! a pair is { length of chain, prime the chain sums to }
+
+: longest-prime ( seq limit -- pair )
+ dupd sum-upto dup prime? [
+ 2array nip
+ ] [
+ [ head-slice ] dip pop-until-prime
+ [ length ] dip 2array
+ ] if ;
+
+: longest ( pair pair -- longest )
+ 2dup [ first ] bi@ > [ drop ] [ nip ] if ;
+
+: continue? ( pair seq -- ? )
+ [ first ] [ length 1- ] bi* < ;
+
+: (find-longest) ( best seq limit -- best )
+ [ longest-prime longest ] 2keep 2over continue? [
+ [ rest-slice ] dip (find-longest)
+ ] [ 2drop ] if ;
+
+: find-longest ( seq limit -- best )
+ { 1 2 } -rot (find-longest) ;
+
+: solve ( n -- answer )
+ [ primes-upto ] keep find-longest second ;
+
+PRIVATE>
+
+: euler050 ( -- answer )
+ 1000000 solve ;
+
+! [ euler050 ] 100 ave-time
+! 291 ms run / 20.6 ms GC ave time - 100 trials
+
+MAIN: euler050
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations fry io kernel make math math.functions math.parser
math.statistics memory tools.time ;
IN: project-euler.ave-time
+: nth-place ( x n -- y )
+ 10 swap ^ [ * round >integer ] keep /f ;
+
: collect-benchmarks ( quot n -- seq )
[
[ datastack ]
- [ '[ _ gc benchmark , ] tuck '[ _ _ with-datastack drop ] ]
+ [
+ '[ _ gc benchmark 1000 / , ] tuck
+ '[ _ _ with-datastack drop ]
+ ]
[ 1- ] tri* swap times call
] { } make ; inline
-: nth-place ( x n -- y )
- 10 swap ^ [ * round ] keep / ;
-
: ave-time ( quot n -- )
[ collect-benchmarks ] keep swap
- [ std 2 nth-place ] [ mean round ] bi [
+ [ std 2 nth-place ] [ mean round >integer ] bi [
# " ms ave run time - " % # " SD (" % # " trials)" %
] "" make print flush ; inline
projects / factor.git / commitdiff