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

fix multi-methods for <=>

db4
Doug Coleman 2008-04-27 22:44:42 -05:00
parent 47abbfc4c6
commit 0d8ddd2a3c
2 changed files with 11 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
extra/multi-methods/multi-methods.factor
View File

@ -73,7 +73,7 @@ SYMBOL: total
! Part II: Topologically sorting specializers ! Part II: Topologically sorting specializers
: maximal-element ( seq quot -- n elt ) : maximal-element ( seq quot -- n elt )
dupd [ dupd [
swapd [ call 0 < ] 2curry filter empty? swapd [ call +lt+ = ] 2curry filter empty?
] 2curry find [ "Topological sort failed" throw ] unless* ; ] 2curry find [ "Topological sort failed" throw ] unless* ;
inline inline
@ -82,16 +82,16 @@ SYMBOL: total
[ dupd maximal-element >r over delete-nth r> ] curry [ dupd maximal-element >r over delete-nth r> ] curry
[ ] unfold nip ; inline [ ] unfold nip ; inline
: classes< ( seq1 seq2 -- -1/0/1 ) : classes< ( seq1 seq2 -- lt/eq/gt )
[ [
{ {
{ [ 2dup eq? ] [ 0 ] } { [ 2dup eq? ] [ +eq+ ] }
{ [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] } { [ 2dup [ class< ] 2keep swap class< and ] [ +eq+ ] }
{ [ 2dup class< ] [ -1 ] } { [ 2dup class< ] [ +lt+ ] }
{ [ 2dup swap class< ] [ 1 ] } { [ 2dup swap class< ] [ +gt+ ] }
[ 0 ] [ +eq+ ]
} cond 2nip } cond 2nip
] 2map [ zero? not ] find nip 0 or ; ] 2map [ zero? not ] find nip +eq+ or ;
: sort-methods ( alist -- alist' ) : sort-methods ( alist -- alist' )
[ [ first ] bi@ classes< ] topological-sort ; [ [ first ] bi@ classes< ] topological-sort ;

6
extra/multi-methods/tests/topological-sort.factor
View File

@ -6,14 +6,14 @@ IN: multi-methods.tests
{ 6 4 5 1 3 2 } [ <=> ] topological-sort { 6 4 5 1 3 2 } [ <=> ] topological-sort
] unit-test ] unit-test
[ -1 ] [ [ +lt+ ] [
{ fixnum array } { number sequence } classes< { fixnum array } { number sequence } classes<
] unit-test ] unit-test
[ 0 ] [ [ +eq+ ] [
{ number sequence } { number sequence } classes< { number sequence } { number sequence } classes<
] unit-test ] unit-test
[ 1 ] [ [ +gt+ ] [
{ object object } { number sequence } classes< { object object } { number sequence } classes<
] unit-test ] unit-test