steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

modern-harvey2
Doug Coleman 2017-07-22 18:49:04 -05:00
parent 62129ffea4
commit 22c20bd887
2 changed files with 31 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
extra/arrays/shaped/shaped-tests.factor
View File

@ -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

36
extra/arrays/shaped/shaped.factor
View File

@ -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{ \ } ;