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
: maximal-element ( seq quot -- n elt )
dupd [
swapd [ call 0 < ] 2curry filter empty?
swapd [ call +lt+ = ] 2curry filter empty?
] 2curry find [ "Topological sort failed" throw ] unless* ;
inline
@ -82,16 +82,16 @@ SYMBOL: total
[ dupd maximal-element >r over delete-nth r> ] curry
[ ] unfold nip ; inline
: classes< ( seq1 seq2 -- -1/0/1 )
: classes< ( seq1 seq2 -- lt/eq/gt )
[
{
{ [ 2dup eq? ] [ 0 ] }
{ [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
{ [ 2dup class< ] [ -1 ] }
{ [ 2dup swap class< ] [ 1 ] }
[ 0 ]
{ [ 2dup eq? ] [ +eq+ ] }
{ [ 2dup [ class< ] 2keep swap class< and ] [ +eq+ ] }
{ [ 2dup class< ] [ +lt+ ] }
{ [ 2dup swap class< ] [ +gt+ ] }
[ +eq+ ]
} cond 2nip
] 2map [ zero? not ] find nip 0 or ;
] 2map [ zero? not ] find nip +eq+ or ;
: sort-methods ( alist -- alist' )
[ [ 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
] unit-test
[ -1 ] [
[ +lt+ ] [
{ fixnum array } { number sequence } classes<
] unit-test
[ 0 ] [
[ +eq+ ] [
{ number sequence } { number sequence } classes<
] unit-test
[ 1 ] [
[ +gt+ ] [
{ object object } { number sequence } classes<
] unit-test