Some fixes and cleanups in math.vectors

- Tighten up type inference for operations on complex float arrays
- Fix v. to have correct behavior with complex numbers
- Rename v<< and v>> to vlshift and vrshift to avoid clashing with v>> accessor

basis/alien/complex/functor/functor.factor

@@ -25,7 +25,7 @@ STRUCT: T-class { real N } { imaginary N } ;
 T-class c-type
 <T> 1quotation >>unboxer-quot
 *T 1quotation >>boxer-quot
-number >>boxed-class
+complex >>boxed-class
 drop
 
 ;FUNCTOR

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -169,8 +169,8 @@ IN: compiler.cfg.intrinsics
         { math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] }
         { math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
         { math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v<<) [ [ ^^shl-vector ] emit-binary-vector-op ] }
+        { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-v>>) [ [ ^^shr-vector ] emit-binary-vector-op ] }
+        { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] }
         { math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] }
         { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
         { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }

basis/compiler/tree/propagation/simd/simd.factor

@@ -19,8 +19,8 @@ IN: compiler.tree.propagation.simd
     (simd-vbitand)
     (simd-vbitor)
     (simd-vbitxor)
-    (simd-v<<)
+    (simd-vlshift)
-    (simd-v>>)
+    (simd-vrshift)
     (simd-broadcast)
     (simd-gather-2)
     (simd-gather-4)

basis/math/vectors/simd/intrinsics/intrinsics.factor

@@ -42,8 +42,8 @@ SIMD-OP: vabs
 SIMD-OP: vbitand
 SIMD-OP: vbitor
 SIMD-OP: vbitxor
-SIMD-OP: v<<
+SIMD-OP: vlshift
-SIMD-OP: v>>
+SIMD-OP: vrshift
 
 : (simd-broadcast) ( x rep -- v ) bad-simd-call ;
 : (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
@@ -112,8 +112,8 @@ M: vector-rep supported-simd-op?
         { \ (simd-vbitand)   [ %and-vector-reps            ] }
         { \ (simd-vbitor)    [ %or-vector-reps             ] }
         { \ (simd-vbitxor)   [ %xor-vector-reps            ] }
-        { \ (simd-v<<)       [ %shl-vector-reps            ] }
+        { \ (simd-vlshift)   [ %shl-vector-reps            ] }
-        { \ (simd-v>>)       [ %shr-vector-reps            ] }
+        { \ (simd-vrshift)   [ %shr-vector-reps            ] }
         { \ (simd-broadcast) [ %broadcast-vector-reps      ] }
         { \ (simd-gather-2)  [ %gather-vector-2-reps       ] }
         { \ (simd-gather-4)  [ %gather-vector-4-reps       ] }

basis/math/vectors/simd/simd-tests.factor

@@ -142,7 +142,7 @@ CONSTANT: simd-classes
     [ drop { vsqrt n/v v/n v/ normalize } member? not ] assoc-filter ;
 
 : remove-integer-words ( alist -- alist' )
-    [ drop { v<< v>> } member? not ] assoc-filter ;
+    [ drop { vlshift vrshift } member? not ] assoc-filter ;
 
 : ops-to-check ( elt-class -- alist )
     [ vector-words >alist ] dip

basis/math/vectors/specialization/specialization-tests.factor

@@ -13,10 +13,14 @@ SPECIALIZED-ARRAY: float
     [ { float-array float } declare v*n norm ] final-classes
 ] unit-test
 
-[ V{ number } ] [
+[ V{ complex } ] [
     [ { complex-float-array complex-float-array } declare v. ] final-classes
 ] unit-test
 
-[ V{ real } ] [
+[ V{ float } ] [
+    [ { float-array float } declare v*n norm ] final-classes
+] unit-test
+
+[ V{ float } ] [
     [ { complex-float-array complex } declare v*n norm ] final-classes
 ] unit-test

basis/math/vectors/specialization/specialization.factor

@@ -30,7 +30,14 @@ SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ;
         {
             { +vector+ [ drop <class-info> ] }
             { +scalar+ [ nip <class-info> ] }
-            { +nonnegative+ [ nip real class-and [0,inf] <class/interval-info> ] }
+            {
+                +nonnegative+
+                [
+                    nip
+                    dup complex class<= [ drop float ] when
+                    [0,inf] <class/interval-info>
+                ]
+            }
         } case
     ] with with map ;
 
@@ -77,8 +84,8 @@ H{
     { vbitand { +vector+ +vector+ -> +vector+ } }
     { vbitor { +vector+ +vector+ -> +vector+ } }
     { vbitxor { +vector+ +vector+ -> +vector+ } }
-    { v>> { +vector+ +scalar+ -> +vector+ } }
+    { vlshift { +vector+ +scalar+ -> +vector+ } }
-    { v<< { +vector+ +scalar+ -> +vector+ } }
+    { vrshift { +vector+ +scalar+ -> +vector+ } }
 }
 
 PREDICATE: vector-word < word vector-words key? ;
@@ -112,9 +119,11 @@ M: vector-word subwords specializations values [ word? ] filter ;
 : vector-words-for-type ( elt-type -- alist )
     {
         ! Can't do shifts on floats
-        { [ dup float class<= ] [ vector-words keys { v<< v>> } diff ] }
+        { [ dup float class<= ] [ vector-words keys { vlshift vrshift } diff ] }
         ! Can't divide integers
         { [ dup integer class<= ] [ vector-words keys { vsqrt n/v v/n v/ normalize } diff ] }
+        ! Can't compute square root of complex numbers (vsqrt uses fsqrt not sqrt)
+        { [ dup complex class<= ] [ vector-words keys { vsqrt } diff ] }
         [ { } ]
     } cond nip ;
 

basis/math/vectors/vectors-docs.factor

@@ -38,8 +38,8 @@ $nl
 { $subsection vbitand }
 { $subsection vbitor }
 { $subsection vbitxor }
-{ $subsection v<< }
+{ $subsection vlshift }
-{ $subsection v>> }
+{ $subsection vrshift }
 "Inner product and norm:"
 { $subsection v. }
 { $subsection norm }
@@ -162,11 +162,7 @@ HELP: vmin
 
 HELP: v.
 { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "x" "a real number" } }
-{ $description "Computes the real-valued dot product." }
+{ $description "Computes the dot product of two vectors." } ;
-{ $notes
-    "This word can also take complex number sequences as input, however mathematically it will compute the wrong result. The complex-valued dot product is defined differently:"
-    { $code "0 [ conjugate * + ] 2reduce" }
-} ;
 
 HELP: vs+
 { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } }
@@ -211,11 +207,11 @@ HELP: vbitxor
 { $description "Takes the bitwise exclusive or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
 { $notes "Unlike " { $link bitxor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
 
-HELP: v<<
+HELP: vlshift
 { $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } }
 { $description "Shifts each element of " { $snippet "u" } " to the left by " { $snippet "n" } " bits." } ;
 
-HELP: v>>
+HELP: vrshift
 { $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } }
 { $description "Shifts each element of " { $snippet "u" } " to the right by " { $snippet "n" } " bits." } ;
 

basis/math/vectors/vectors-tests.factor

@@ -1,5 +1,5 @@
 IN: math.vectors.tests
-USING: math.vectors tools.test ;
+USING: math.vectors tools.test kernel ;
 
 [ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test
 [ { 1 2 3 } ] [ { 2 4 6 } 1/2 v*n ] unit-test
@@ -19,4 +19,6 @@ USING: math.vectors tools.test ;
 
 [ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
 
-[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test
+[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test
+
+[ 1 ] [ { C{ 0 1 } } dup v. ] unit-test

basis/math/vectors/vectors.factor

@@ -61,8 +61,8 @@ PRIVATE>
 : vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ;
 : vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
 
-: v<< ( u n -- w ) '[ _ shift ] map ;
+: vlshift ( u n -- w ) '[ _ shift ] map ;
-: v>> ( u n -- w ) neg '[ _ shift ] map ;
+: vrshift ( u n -- w ) neg '[ _ shift ] map ;
 
 : vfloor    ( u -- v ) [ floor ] map ;
 : vceiling  ( u -- v ) [ ceiling ] map ;
@@ -71,7 +71,7 @@ PRIVATE>
 : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; 
 : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; 
 
-: v. ( u v -- x ) [ * ] [ + ] 2map-reduce ;
+: v. ( u v -- x ) [ conjugate * ] [ + ] 2map-reduce ;
 : norm-sq ( v -- x ) [ absq ] [ + ] map-reduce ;
 : norm ( v -- x ) norm-sq sqrt ;
 : normalize ( u -- v ) dup norm v/n ;