Merge branch 'master' of git://factorcode.org/git/factor

diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index d5ac3b687811e00d6e315ff75a11558c78a6dfe2..7126806c3d20d013f6ab022e0fbafe94c8277bce 100644 (file)
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -17,7 +17,7 @@ IN: functors
     scan-param parsed
     scan {
         { ";" [ tuple parsed f parsed ] }
-        { "<" [ scan-param [ parse-tuple-slots ] { } make parsed ] }
+        { "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] }
         [
             [ tuple parsed ] dip
             [ parse-slot-name [ parse-tuple-slots ] when ] { }

diff --git a/extra/math/blas/cblas/cblas.factor b/extra/math/blas/cblas/cblas.factor
index 58f179af804d45a4086802767d8f870584858c9c..4c0a88f92938778c156fda659b4e8b51a3d69340 100644 (file)
--- a/extra/math/blas/cblas/cblas.factor
+++ b/extra/math/blas/cblas/cblas.factor
@@ -34,10 +34,10 @@ TYPEDEF: int CBLAS_SIDE
 
 TYPEDEF: int CBLAS_INDEX
 
-C-STRUCT: CBLAS_C
+C-STRUCT: float-complex
     { "float" "real" }
     { "float" "imag" } ;
-C-STRUCT: CBLAS_Z
+C-STRUCT: double-complex
     { "double" "real" }
     { "double" "imag" } ;
 
@@ -53,14 +53,14 @@ 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 ) ;
+    ( int N,                 void*    X, int incX, void*    Y, int incY, void*    dotu ) ;
 FUNCTION: void   cblas_cdotc_sub
-    ( int N,                 CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotc ) ;
+    ( int N,                 void*    X, int incX, void*    Y, int incY, void*    dotc ) ;
 
 FUNCTION: void   cblas_zdotu_sub
-    ( int N,                 CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotu ) ;
+    ( int N,                 void*    X, int incX, void*    Y, int incY, void*    dotu ) ;
 FUNCTION: void   cblas_zdotc_sub
-    ( int N,                 CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotc ) ;
+    ( int N,                 void*    X, int incX, void*    Y, int incY, void*    dotc ) ;
 
 FUNCTION: float  cblas_snrm2
     ( int N,                 float*   X, int incX ) ;
@@ -73,23 +73,23 @@ FUNCTION: double cblas_dasum
     ( int N,                 double*  X, int incX ) ;
 
 FUNCTION: float  cblas_scnrm2
-    ( int N,                 CBLAS_C* X, int incX ) ;
+    ( int N,                 void*    X, int incX ) ;
 FUNCTION: float  cblas_scasum
-    ( int N,                 CBLAS_C* X, int incX ) ;
+    ( int N,                 void*    X, int incX ) ;
 
 FUNCTION: double cblas_dznrm2
-    ( int N,                 CBLAS_Z* X, int incX ) ;
+    ( int N,                 void*    X, int incX ) ;
 FUNCTION: double cblas_dzasum
-    ( int N,                 CBLAS_Z* X, int incX ) ;
+    ( int N,                 void*    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 ) ;
+    ( int N,                 void*    X, int incX ) ;
 FUNCTION: CBLAS_INDEX cblas_izamax
-    ( int N,                 CBLAS_Z* X, int incX ) ;
+    ( int N,                 void*    X, int incX ) ;
 
 FUNCTION: void cblas_sswap
     ( int N,                 float*   X, int incX, float*   Y, int incY ) ;
@@ -106,31 +106,31 @@ 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 ) ;
+    ( int N,                 void*    X, int incX, void*    Y, int incY ) ;
 FUNCTION: void cblas_ccopy
-    ( int N,                 CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
+    ( int N,                 void*    X, int incX, void*    Y, int incY ) ;
 FUNCTION: void cblas_caxpy
-    ( int N, CBLAS_C* alpha, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
+    ( int N, void*    alpha, void*    X, int incX, void*    Y, int incY ) ;
 
 FUNCTION: void cblas_zswap
-    ( int N,                 CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
+    ( int N,                 void*    X, int incX, void*    Y, int incY ) ;
 FUNCTION: void cblas_zcopy
-    ( int N,                 CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
+    ( int N,                 void*    X, int incX, void*    Y, int incY ) ;
 FUNCTION: void cblas_zaxpy
-    ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
+    ( int N, void*    alpha, void*    X, int incX, void*    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 ) ;
+    ( int N, void*    alpha, void*    X, int incX ) ;
 FUNCTION: void cblas_zscal
-    ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX ) ;
+    ( int N, void*    alpha, void*    X, int incX ) ;
 FUNCTION: void cblas_csscal
-    ( int N, float    alpha, CBLAS_C* X, int incX ) ;
+    ( int N, float    alpha, void*    X, int incX ) ;
 FUNCTION: void cblas_zdscal
-    ( int N, double   alpha, CBLAS_Z* X, int incX ) ;
+    ( int N, double   alpha, void*    X, int incX ) ;
 
 FUNCTION: void cblas_srotg
     ( float* a, float* b, float* c, float* s ) ;

diff --git a/extra/math/blas/vectors/vectors-docs.factor b/extra/math/blas/vectors/vectors-docs.factor
index 0595f0098916bd36df030bd4eb97ca0a731a2ab9..cb26d67334a4080c18ac701b86c44f12a1459366 100644 (file)
--- a/extra/math/blas/vectors/vectors-docs.factor
+++ b/extra/math/blas/vectors/vectors-docs.factor
@@ -37,7 +37,7 @@ HELP: blas-vector-base
 }
 "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 "underlying" } " 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." }
 } } ;

diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor
index f29ef30ab7447f0ae1dd0eb96c85baa95721e434..c22901237015e6fddb284508301127a0a5dbbf00 100755 (executable)
--- a/extra/math/blas/vectors/vectors.factor
+++ b/extra/math/blas/vectors/vectors.factor
@@ -1,137 +1,101 @@
 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
+combinators.short-circuit fry kernel math math.blas.cblas
+math.complex math.functions math.order sequences.complex
+sequences.complex-components sequences sequences.private
+generalizations functors words locals
 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 ;
+TUPLE: blas-vector-base underlying length inc ;
 
-INSTANCE: float-blas-vector sequence
-INSTANCE: double-blas-vector sequence
-INSTANCE: float-complex-blas-vector sequence
-INSTANCE: double-complex-blas-vector sequence
+INSTANCE: blas-vector-base virtual-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: element-type ( v -- type )
 
 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 ;
+GENERIC: (blas-direct-array) ( blas-vector -- direct-array )
+
+: shorter-length ( v1 v2 -- length )
+    [ length>> ] bi@ min ; inline
+: data-and-inc ( v -- data inc )
+    [ underlying>> ] [ inc>> ] bi ; inline
+: datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc )
+    [ data-and-inc ] bi@ ; inline
+
+:: (prepare-copy)
+    ( v element-size -- length v-data v-inc v-dest-data v-dest-inc
+                        copy-data copy-length copy-inc )
+    v [ length>> ] [ data-and-inc ] bi
+    v length>> element-size * <byte-array>
+    1 
+    over v length>> 1 ;
+
+: (prepare-swap)
+    ( v1 v2 -- length v1-data v1-inc v2-data v2-inc
+               v1 v2 )
+    [ shorter-length ] [ datas-and-incs ] [ ] 2tri ;
+
+:: (prepare-axpy)
+    ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc
+                 v2 )
+    v1 v2 shorter-length
+    n
+    v1 v2 datas-and-incs
+    v2 ;
+
+:: (prepare-scal)
+    ( n v -- length n v-data v-inc
+             v )
+    v length>>
+    n
+    v data-and-inc
+    v ;
 
 : (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) ;
+    [ shorter-length ] [ datas-and-incs ] 2bi ;
+
+: (prepare-nrm2) ( v -- length data inc )
+    [ length>> ] [ data-and-inc ] bi ;
 
 PRIVATE>
 
+: 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
+
+: Vamax ( x -- max )
+    [ Viamax ] keep nth ; inline
+
+:: Vsub ( v start length -- sub )
+    v inc>> start * v element-type heap-size *
+    v underlying>> <displaced-alien>
+    length v inc>> v (blas-vector-like) ;
+
 : <zero-vector> ( exemplar -- zero )
     [ element-type <c-object> ]
     [ length>> 0 ]
@@ -142,162 +106,152 @@ PRIVATE>
     [ 1 swap ] 2bi
     (blas-vector-like) ;
 
-syntax:M: blas-vector-base length
+M: blas-vector-base equal?
+    {
+        [ [ length ] bi@ = ]
+        [ [ = ] 2all? ]
+    } 2&& ;
+
+M: blas-vector-base length
     length>> ;
+M: blas-vector-base virtual-seq
+    (blas-direct-array) ;
+M: blas-vector-base virtual@
+    [ inc>> * ] [ nip (blas-direct-array) ] 2bi ;
 
-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) ;
+FUNCTOR: (define-blas-vector) ( TYPE T -- )
 
-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) ;
+<DIRECT-ARRAY> IS <direct-${TYPE}-array>
+>ARRAY         IS >${TYPE}-array
+XCOPY          IS cblas_${T}copy
+XSWAP          IS cblas_${T}swap
+XAXPY          IS cblas_${T}axpy
+XSCAL          IS cblas_${T}scal
+IXAMAX         IS cblas_i${T}amax
 
-syntax:M: blas-vector-base equal?
-    {
-        [ [ length ] bi@ = ]
-        [ [ = ] 2all? ]
-    } 2&& ;
+VECTOR         DEFINES ${TYPE}-blas-vector
+<VECTOR>       DEFINES <${TYPE}-blas-vector>
+>VECTOR        DEFINES >${TYPE}-blas-vector
 
-: >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 ;
+WHERE
 
-: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
-: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
+TUPLE: VECTOR < blas-vector-base ;
+: <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; 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
+: >VECTOR ( seq -- v )
+    [ >ARRAY execute underlying>> ] [ length ] bi 1 <VECTOR> execute ;
 
-: Vneg ( x -- -x )
-    -1.0 swap n*V ; inline
+M: VECTOR clone
+    TYPE heap-size (prepare-copy)
+    [ XCOPY execute ] 3dip <VECTOR> execute ;
 
-: V*n ( x alpha -- x*alpha )
-    swap n*V ; inline
-: V/n ( x alpha -- x/alpha )
-    recip swap n*V ; inline
+M: VECTOR element-type
+    drop TYPE ;
+M: VECTOR n*V+V!
+    (prepare-axpy) [ XAXPY execute ] dip ;
+M: VECTOR n*V!
+    (prepare-scal) [ XSCAL execute ] dip ;
+M: VECTOR Vswap
+    (prepare-swap) [ XSWAP execute ] 2dip ;
+M: VECTOR Viamax
+    (prepare-nrm2) IXAMAX execute ;
 
-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 ;
+M: VECTOR (blas-vector-like)
+    drop <VECTOR> execute ;
 
-: Vamax ( x -- max )
-    [ Viamax ] keep nth ; inline
+M: VECTOR (blas-direct-array)
+    [ underlying>> ]
+    [ [ length>> ] [ inc>> ] bi * ] bi
+    <DIRECT-ARRAY> execute ;
+
+;FUNCTOR
+
+
+FUNCTOR: (define-real-blas-vector) ( TYPE T -- )
+
+VECTOR         IS ${TYPE}-blas-vector
+XDOT           IS cblas_${T}dot
+XNRM2          IS cblas_${T}nrm2
+XASUM          IS cblas_${T}asum
+
+WHERE
+
+M: VECTOR V.
+    (prepare-dot) XDOT execute ;
+M: VECTOR V.conj
+    (prepare-dot) XDOT execute ;
+M: VECTOR Vnorm
+    (prepare-nrm2) XNRM2 execute ;
+M: VECTOR Vasum
+    (prepare-nrm2) XASUM execute ;
+
+;FUNCTOR
+
+
+FUNCTOR: (define-complex-helpers) ( TYPE -- )
+
+<DIRECT-COMPLEX-ARRAY> DEFINES <direct-${TYPE}-complex-array>
+>COMPLEX-ARRAY         DEFINES >${TYPE}-complex-array
+ALIEN>COMPLEX          DEFINES alien>${TYPE}-complex
+<DIRECT-ARRAY>         IS      <direct-${TYPE}-array>
+>ARRAY                 IS      >${TYPE}-array
+
+WHERE
+
+: <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
+    <DIRECT-ARRAY> execute <complex-sequence> ;
+: >COMPLEX-ARRAY ( sequence -- sequence )
+    <complex-components> >ARRAY execute ;
+: ALIEN>COMPLEX ( alien -- complex )
+    2 <DIRECT-ARRAY> execute first2 rect> ;
+
+;FUNCTOR
+
+
+FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- )
+
+VECTOR         IS ${TYPE}-blas-vector
+XDOTU_SUB      IS cblas_${C}dotu_sub
+XDOTC_SUB      IS cblas_${C}dotc_sub
+XXNRM2         IS cblas_${S}${C}nrm2
+XXASUM         IS cblas_${S}${C}asum
+ALIEN>TYPE     IS alien>${TYPE}
+
+WHERE
+
+M: VECTOR V.
+    (prepare-dot) TYPE <c-object>
+    [ XDOTU_SUB execute ] keep
+    ALIEN>TYPE execute ;
+M: VECTOR V.conj
+    (prepare-dot) TYPE <c-object>
+    [ XDOTC_SUB execute ] keep
+    ALIEN>TYPE execute ;
+M: VECTOR Vnorm
+    (prepare-nrm2) XXNRM2 execute ;
+M: VECTOR Vasum
+    (prepare-nrm2) XXASUM execute ;
+
+;FUNCTOR
+
+
+: define-real-blas-vector ( TYPE T -- )
+    [ (define-blas-vector) ]
+    [ (define-real-blas-vector) ] 2bi ;
+:: define-complex-blas-vector ( TYPE C S -- )
+    TYPE (define-complex-helpers)
+    TYPE "-complex" append
+    [ C (define-blas-vector) ]
+    [ C S (define-complex-blas-vector) ] bi
+    ;
+
+"float"  "s" define-real-blas-vector
+"double" "d" define-real-blas-vector
+"float"  "c" "s" define-complex-blas-vector
+"double" "z" "d" define-complex-blas-vector
+
+>>
 
-: 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) ;

diff --git a/extra/sequences/complex-components/authors.txt b/extra/sequences/complex-components/authors.txt
new file mode 100644 (file)
index 0000000..f13c9c1
--- /dev/null
+++ b/extra/sequences/complex-components/authors.txt
@@ -0,0 +1 @@
+Joe Groff

diff --git a/extra/sequences/complex-components/complex-components-docs.factor b/extra/sequences/complex-components/complex-components-docs.factor
new file mode 100644 (file)
index 0000000..de1bed3
--- /dev/null
+++ b/extra/sequences/complex-components/complex-components-docs.factor
@@ -0,0 +1,33 @@
+USING: help.markup help.syntax math multiline
+sequences sequences.complex-components ;
+IN: sequences.complex-components
+
+ARTICLE: "sequences.complex-components" "Complex component virtual sequences"
+"The " { $link complex-components } " class wraps a sequence of " { $link complex } " number values, presenting a sequence of " { $link real } " values made by interleaving the real and imaginary parts of the complex values in the original sequence."
+{ $subsection complex-components }
+{ $subsection <complex-components> } ;
+
+ABOUT: "sequences.complex-components"
+
+HELP: complex-components
+{ $class-description "Sequence wrapper class that transforms a sequence of " { $link complex } " number values into a sequence of " { $link real } " values, interleaving the real and imaginary parts of the complex values in the original sequence." }
+{ $examples { $example <"
+USING: sequences arrays sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array
+"> "{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ;
+
+HELP: <complex-components>
+{ $values { "sequence" sequence } { "complex-components" complex-components } }
+{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-components } " wrapper." }
+{ $examples
+{ $example <"
+USING: sequences arrays sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third
+"> "-2.0" }
+{ $example <"
+USING: sequences arrays sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth
+"> "0" }
+} ;
+
+{ complex-components <complex-components> } related-words

diff --git a/extra/sequences/complex-components/complex-components-tests.factor b/extra/sequences/complex-components/complex-components-tests.factor
new file mode 100644 (file)
index 0000000..f0c8e92
--- /dev/null
+++ b/extra/sequences/complex-components/complex-components-tests.factor
@@ -0,0 +1,16 @@
+USING: sequences.complex-components
+kernel sequences tools.test arrays accessors ;
+IN: sequences.complex-components.tests
+
+: test-array ( -- x )
+    { C{ 1.0 2.0 } 3.0 C{ 5.0 6.0 } } <complex-components> ;
+
+[ 6 ] [ test-array length ] unit-test
+
+[ 1.0 ] [ test-array first  ] unit-test
+[ 2.0 ] [ test-array second ] unit-test
+[ 3.0 ] [ test-array third  ] unit-test
+[ 0   ] [ test-array fourth ] unit-test
+
+[ { 1.0 2.0 3.0 0 5.0 6.0 } ] [ test-array >array ] unit-test
+

diff --git a/extra/sequences/complex-components/complex-components.factor b/extra/sequences/complex-components/complex-components.factor
new file mode 100644 (file)
index 0000000..bca7e2c
--- /dev/null
+++ b/extra/sequences/complex-components/complex-components.factor
@@ -0,0 +1,28 @@
+USING: accessors kernel math math.functions combinators
+sequences sequences.private ;
+IN: sequences.complex-components
+
+TUPLE: complex-components seq ;
+INSTANCE: complex-components sequence
+
+: <complex-components> ( sequence -- complex-sequence )
+    complex-components boa ; inline
+
+<PRIVATE
+
+: complex-components@ ( n seq -- remainder n' seq' )
+    [ [ 1 bitand ] [ -1 shift ] bi ] [ seq>> ] bi* ; inline
+: complex-component ( remainder complex -- component )
+    swap {
+        { 0 [ real-part ] }
+        { 1 [ imaginary-part ] }
+    } case ;
+
+PRIVATE>
+
+M: complex-components length
+    seq>> length 1 shift ;
+M: complex-components nth-unsafe
+    complex-components@ nth-unsafe complex-component ;
+M: complex-components set-nth-unsafe
+    immutable ;

diff --git a/extra/sequences/complex-components/summary.txt b/extra/sequences/complex-components/summary.txt
new file mode 100644 (file)
index 0000000..af00158
--- /dev/null
+++ b/extra/sequences/complex-components/summary.txt
@@ -0,0 +1 @@
+Virtual sequence wrapper to convert complex values into real value pairs

diff --git a/extra/sequences/complex-components/tags.txt b/extra/sequences/complex-components/tags.txt
new file mode 100644 (file)
index 0000000..64cdcd9
--- /dev/null
+++ b/extra/sequences/complex-components/tags.txt
@@ -0,0 +1,2 @@
+sequences
+math

diff --git a/extra/sequences/complex/authors.txt b/extra/sequences/complex/authors.txt
new file mode 100644 (file)
index 0000000..f13c9c1
--- /dev/null
+++ b/extra/sequences/complex/authors.txt
@@ -0,0 +1 @@
+Joe Groff

diff --git a/extra/sequences/complex/complex-docs.factor b/extra/sequences/complex/complex-docs.factor
new file mode 100644 (file)
index 0000000..d4d8dfc
--- /dev/null
+++ b/extra/sequences/complex/complex-docs.factor
@@ -0,0 +1,29 @@
+USING: help.markup help.syntax math multiline
+sequences sequences.complex ;
+IN: sequences.complex
+
+ARTICLE: "sequences.complex" "Complex virtual sequences"
+"The " { $link complex-sequence } " class wraps a sequence of " { $link real } " number values, presenting a sequence of " { $link complex } " values made by treating the underlying sequence as pairs of alternating real and imaginary values."
+{ $subsection complex-sequence }
+{ $subsection <complex-sequence> } ;
+
+ABOUT: "sequences.complex"
+
+HELP: complex-sequence
+{ $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values."  }
+{ $examples { $example <"
+USING: specialized-arrays.double sequences.complex
+sequences arrays ;
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array
+"> "{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
+
+HELP: <complex-sequence>
+{ $values { "sequence" sequence } { "complex-sequence" complex-sequence } }
+{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." }
+{ $examples { $example <"
+USING: specialized-arrays.double sequences.complex
+sequences arrays ;
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second
+"> "C{ -2.0 2.0 }" } } ;
+
+{ complex-sequence <complex-sequence> } related-words

diff --git a/extra/sequences/complex/complex-tests.factor b/extra/sequences/complex/complex-tests.factor
new file mode 100644 (file)
index 0000000..5861bc8
--- /dev/null
+++ b/extra/sequences/complex/complex-tests.factor
@@ -0,0 +1,26 @@
+USING: specialized-arrays.float sequences.complex
+kernel sequences tools.test arrays accessors ;
+IN: sequences.complex.tests
+
+: test-array ( -- x )
+    float-array{ 1.0 2.0 3.0 4.0 } clone <complex-sequence> ;
+: odd-length-test-array ( -- x )
+    float-array{ 1.0 2.0 3.0 4.0 5.0 } clone <complex-sequence> ;
+
+[ 2 ] [ test-array length ] unit-test
+[ 2 ] [ odd-length-test-array length ] unit-test
+
+[ C{ 1.0 2.0 } ] [ test-array first ] unit-test
+[ C{ 3.0 4.0 } ] [ test-array second ] unit-test
+
+[ { C{ 1.0 2.0 } C{ 3.0 4.0 } } ]
+[ test-array >array ] unit-test
+
+[ float-array{ 1.0 2.0 5.0 6.0 } ]
+[ test-array [ C{ 5.0 6.0 } 1 rot set-nth ] [ seq>> ] bi ]
+unit-test
+
+[ float-array{ 7.0 0.0 3.0 4.0 } ]
+[ test-array [ 7.0 0 rot set-nth ] [ seq>> ] bi ]
+unit-test
+

diff --git a/extra/sequences/complex/complex.factor b/extra/sequences/complex/complex.factor
new file mode 100644 (file)
index 0000000..93f9727
--- /dev/null
+++ b/extra/sequences/complex/complex.factor
@@ -0,0 +1,25 @@
+USING: accessors kernel math math.functions
+sequences sequences.private ;
+IN: sequences.complex
+
+TUPLE: complex-sequence seq ;
+INSTANCE: complex-sequence sequence
+
+: <complex-sequence> ( sequence -- complex-sequence )
+    complex-sequence boa ; inline
+
+<PRIVATE
+
+: complex@ ( n seq -- n' seq' )
+    [ 1 shift ] [ seq>> ] bi* ; inline
+
+PRIVATE>
+
+M: complex-sequence length
+    seq>> length -1 shift ;
+M: complex-sequence nth-unsafe
+    complex@ [ nth-unsafe ] [ [ 1+ ] dip nth-unsafe ] 2bi rect> ;
+M: complex-sequence set-nth-unsafe
+    complex@
+    [ [ real-part      ] [    ] [ ] tri* set-nth-unsafe ]
+    [ [ imaginary-part ] [ 1+ ] [ ] tri* set-nth-unsafe ] 3bi ;

diff --git a/extra/sequences/complex/summary.txt b/extra/sequences/complex/summary.txt
new file mode 100644 (file)
index 0000000..d94c4ba
--- /dev/null
+++ b/extra/sequences/complex/summary.txt
@@ -0,0 +1 @@
+Virtual sequence wrapper to convert real pairs into complex values

diff --git a/extra/sequences/complex/tags.txt b/extra/sequences/complex/tags.txt
new file mode 100644 (file)
index 0000000..64cdcd9
--- /dev/null
+++ b/extra/sequences/complex/tags.txt
@@ -0,0 +1,2 @@
+sequences
+math