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

sequences: fix supremum-by and infimum-by to be row polymorphic.

db4
John Benediktsson 2013-04-10 11:10:01 -07:00
parent 5c225fa09f
commit 86ad529ed7
2 changed files with 11 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/sequences/sequences-tests.factor
View File

@ -1,7 +1,7 @@
USING: arrays byte-arrays kernel math math.order math.parser USING: arrays byte-arrays kernel math math.order math.parser
namespaces sequences kernel.private sequences.private strings namespaces sequences kernel.private sequences.private strings
sbufs tools.test vectors assocs generic vocabs.loader sbufs tools.test vectors assocs generic vocabs.loader
generic.single math.vectors ; generic.single math.vectors math.functions ;
IN: sequences.tests IN: sequences.tests
[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test [ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test
@ -359,6 +359,8 @@ USE: make
{ "bar" } [ { "bar" "baz" "qux" } [ length ] infimum-by ] unit-test { "bar" } [ { "bar" "baz" "qux" } [ length ] infimum-by ] unit-test
[ { "foo" } ] [ { { "foo" } { "bar" } } [ first ] supremum-by ] unit-test [ { "foo" } ] [ { { "foo" } { "bar" } } [ first ] supremum-by ] unit-test
[ { "bar" } ] [ { { "foo" } { "bar" } } [ first ] infimum-by ] unit-test [ { "bar" } ] [ { { "foo" } { "bar" } } [ first ] infimum-by ] unit-test
{ -2 1 } [ -2 { 1 2 3 } [ over ^ ] supremum-by ] unit-test
{ -2 3 } [ -2 { 1 2 3 } [ over ^ ] infimum-by ] unit-test
[ { 0 0 255 } ] [ [ { 0 0 255 } ] [
{ {

16
core/sequences/sequences.factor
View File

@ -1031,16 +1031,16 @@ M: object sum 0 [ + ] binary-reduce ; inline
: each-from ( ... seq quot: ( ... x -- ... ) i -- ... ) : each-from ( ... seq quot: ( ... x -- ... ) i -- ... )
-rot (each) (each-integer) ; inline -rot (each) (each-integer) ; inline
: supremum-by ( seq quot: ( ... elt -- ... x ) -- elt ) : supremum-by ( ... seq quot: ( ... elt -- ... x ) -- ... elt )
[ [ first dup ] dip call ] 2keep [ [ keep swap ] curry [ [ first ] dip call ] 2keep [
dupd call pick dupd after? curry 2dip pick over after?
[ [ 2drop ] 2dip ] [ 2drop ] if [ 2drop ] [ [ 2drop ] 2dip ] if
] curry 1 each-from drop ; inline ] curry 1 each-from drop ; inline
: infimum-by ( seq quot: ( ... elt -- ... x ) -- elt ) : infimum-by ( ... seq quot: ( ... elt -- ... x ) -- ... elt )
[ [ first dup ] dip call ] 2keep [ [ keep swap ] curry [ [ first ] dip call ] 2keep [
dupd call pick dupd before? curry 2dip pick over before?
[ [ 2drop ] 2dip ] [ 2drop ] if [ 2drop ] [ [ 2drop ] 2dip ] if
] curry 1 each-from drop ; inline ] curry 1 each-from drop ; inline
: shortest ( seqs -- elt ) [ length ] infimum-by ; : shortest ( seqs -- elt ) [ length ] infimum-by ;