arrays.shaped: A bit of work on arrays.shaped.

diff --git a/extra/arrays/shaped/shaped-tests.factor b/extra/arrays/shaped/shaped-tests.factor
index 9dfb228616a3d17cfe72b25a826650b361fc8255..6a74f434846607c57f0507684236d24b520eaacf 100644 (file)
--- a/extra/arrays/shaped/shaped-tests.factor
+++ b/extra/arrays/shaped/shaped-tests.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2012 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays.shaped kernel tools.test math ;
+USING: accessors arrays.shaped kernel math sequences tools.test ;
 IN: arrays.shaped.tests
 
 { t } [
@@ -50,3 +50,6 @@ IN: arrays.shaped.tests
     [ drop 1 ] map-diagonal
     [ sq ] map-strict-lower
 ] unit-test
+
+
+{ } [ 15 <iota> { 3 5 1 } reshape drop ] unit-test
\ No newline at end of file

diff --git a/extra/arrays/shaped/shaped.factor b/extra/arrays/shaped/shaped.factor
index 2577556131937bf7e7b16caf34e17104e1b26113..e02ef76edd9e6ab46b42bb9a3084dab1f33b6719 100644 (file)
--- a/extra/arrays/shaped/shaped.factor
+++ b/extra/arrays/shaped/shaped.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2012 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators.short-circuit constructors
-fry grouping kernel math math.vectors sequences sequences.deep
-math.order parser assocs math.combinatorics ;
+USING: accessors arrays assocs combinators.short-circuit fry
+grouping kernel math math.functions math.order math.vectors
+parser prettyprint.custom sequences sequences.deep ;
 IN: arrays.shaped
 
 : flat? ( array -- ? ) [ sequence? ] any? not ; inline
@@ -79,7 +79,10 @@ M: sequence check-underlying-shape
 
 ERROR: shape-mismatch shaped0 shaped1 ;
 
+DEFER: >shaped-array
+
 : check-shape ( shaped-array shaped-array -- shaped-array shaped-array )
+    [ >shaped-array ] bi@
     2dup [ shape>> ] bi@
     sequence= [ shape-mismatch ] unless ;
 
@@ -123,10 +126,25 @@ M: shaped-array >col-array
 M: sequence >col-array
     [ flatten ] [ shape ] bi <col-array> ;
 
-: shaped+ ( a b -- c )
-    check-shape
-    [ [ underlying>> ] bi@ v+ ]
-    [ drop shape>> clone ] 2bi shaped-array boa ;
+: shaped-unary-op ( shaped quot -- )
+    [ >shaped-array ] dip
+    [ underlying>> ] prepose
+    [ shape>> clone ] bi shaped-array boa ; inline
+
+: shaped-shaped-binary-op ( shaped0 shaped1 quot -- c )
+    [ check-shape ] dip
+    [ [ underlying>> ] bi@ ] prepose
+    [ drop shape>> clone ] 2bi shaped-array boa ; inline
+
+: shaped+ ( a b -- c ) [ v+ ] shaped-shaped-binary-op ;
+: shaped- ( a b -- c ) [ v- ] shaped-shaped-binary-op ;
+: shaped*. ( a b -- c ) [ v* ] shaped-shaped-binary-op ;
+
+: shaped*n ( a b -- c ) [ v*n ] curry shaped-unary-op ;
+: n*shaped ( a b -- c ) swap shaped*n ;
+
+: shaped-cos ( a -- b ) [ [ cos ] map ] shaped-unary-op ;
+: shaped-sin ( a -- b ) [ [ sin ] map ] shaped-unary-op ;
 
 : shaped-array>array ( shaped-array -- array )
     [ underlying>> ] [ shape>> ] bi
@@ -137,7 +155,8 @@ M: sequence >col-array
     ] if ;
 
 : reshape ( shaped-array shape -- array )
-    check-underlying-shape >>shape ;
+    check-underlying-shape
+    [ >shaped-array ] dip >>shape ;
 
 : shaped-like ( shaped-array shape -- array )
     [ underlying>> clone ] dip <shaped-array> ;
@@ -175,7 +194,6 @@ GENERIC: next-index ( object -- index )
 
 SYNTAX: sa{ \ } [ >shaped-array ] parse-literal ;
 
-USE: prettyprint.custom
 ! M: row-array pprint* shaped-array>array pprint* ;
 ! M: col-array pprint* shaped-array>array flip pprint* ;
 M: shaped-array pprint-delims drop \ sa{ \ } ;