diff --git a/extra/arrays/shaped/shaped-tests.factor b/extra/arrays/shaped/shaped-tests.factor index 9dfb228616..6a74f43484 100644 --- 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 { 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 2577556131..e02ef76edd 100644 --- 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 ; -: 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 ; @@ -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{ \ } ;