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

Topology fixes

release
slava 2006-08-30 09:40:36 +00:00
parent 4b37d92d7e
commit b541418b9a
3 changed files with 20 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
contrib/topology/matrix.factor
View File

@ -62,13 +62,16 @@ SYMBOL: matrix
: pivot-row ( col# row# -- n ) : pivot-row ( col# row# -- n )
[ dupd nth-row nth zero? not ] find-row 2nip ; [ dupd nth-row nth zero? not ] find-row 2nip ;
: (row-reduce) ( -- ) : (row-reduce) ( col# row# -- )
0 cols rows min [ over cols < over rows < and [
over pivot-row [ over do-row 1+ ] when* 2dup pivot-row [ over do-row 1+ ] when* >r 1+ r>
] each drop ; (row-reduce)
] [
2drop
] if ;
: row-reduce ( matrix -- matrix' ) : row-reduce ( matrix -- matrix' )
[ (row-reduce) ] with-matrix ; [ 0 0 (row-reduce) ] with-matrix ;
: null/rank ( matrix -- null rank ) : null/rank ( matrix -- null rank )
row-reduce [ [ [ zero? ] all? ] subset ] keep row-reduce [ [ [ zero? ] all? ] subset ] keep

2
contrib/topology/test/laplacian.factor
View File

@ -13,5 +13,5 @@ SYMBOLS: x y z ;
[ t ] [ y star z x h* = ] unit-test [ t ] [ y star z x h* = ] unit-test
[ t ] [ z star x y h* = ] unit-test [ t ] [ z star x y h* = ] unit-test
[ 1 ] [ x x <,>* ] unit-test [ -1 ] [ x x <,>* ] unit-test
[ 0 ] [ x y <,>* ] unit-test [ 0 ] [ x y <,>* ] unit-test

11
contrib/topology/test/matrix.factor
View File

@ -232,3 +232,14 @@ USING: kernel matrices test ;
{ 1 1 0 1 } { 1 1 0 1 }
} null/rank } null/rank
] unit-test ] unit-test
[
1 3
] [
{
{ 0 0 0 0 0 1 0 1 }
{ 0 0 0 0 1 0 0 1 }
{ 0 0 0 0 1 0 0 0 }
{ 0 0 0 0 1 1 0 1 }
} null/rank
] unit-test