Clean up spectral-norm

db4
Slava Pestov 2008-04-20 06:15:24 -05:00
parent e9b9172a8e
commit 8ce5760fcc
1 changed files with 23 additions and 27 deletions

View File

@ -1,48 +1,44 @@
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
USING: float-arrays kernel math math.functions math.vectors
sequences sequences.private prettyprint words tools.time hints ;
sequences sequences.private prettyprint words
hints locals ;
IN: benchmark.spectral-norm
: fast-truncate >fixnum >float ; inline
:: inner-loop ( u n quot -- seq )
n [| i |
n 0.0 [| j |
u i j quot call +
] reduce
] F{ } map-as ; inline
: eval-A ( i j -- n )
[ >float ] bi@
dupd + dup 1+ * 2 /f fast-truncate + 1+
recip ; inline
[ drop ] [ + [ ] [ 1 + ] bi * 0.5 * ] 2bi
+ 1 + recip ; inline
: (eval-A-times-u) ( u i j -- x )
tuck eval-A >r swap nth-unsafe r> * ; inline
tuck [ swap nth-unsafe ] [ eval-A ] 2bi* * ; inline
: eval-A-times-u ( n u -- seq )
over [
pick 0.0 [
swap >r >r 2dup r> (eval-A-times-u) r> +
] reduce nip
] F{ } map-as 2nip ; inline
[ (eval-A-times-u) ] inner-loop ; inline
: (eval-At-times-u) ( u i j -- x )
tuck swap eval-A >r swap nth-unsafe r> * ; inline
tuck [ swap nth-unsafe ] [ swap eval-A ] 2bi* * ; inline
: eval-At-times-u ( n u -- seq )
over [
pick 0.0 [
swap >r >r 2dup r> (eval-At-times-u) r> +
] reduce nip
] F{ } map-as 2nip ; inline
: eval-At-times-u ( u n -- seq )
[ (eval-At-times-u) ] inner-loop ; inline
: eval-AtA-times-u ( n u -- seq )
dupd eval-A-times-u eval-At-times-u ; inline
: eval-AtA-times-u ( u n -- seq )
[ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
: u/v ( n -- u v )
dup 1.0 <float-array> dup
:: u/v ( n -- u v )
n 1.0 <float-array> dup
10 [
drop
dupd eval-AtA-times-u
2dup eval-AtA-times-u
swap
] times
rot drop ; inline
n eval-AtA-times-u
[ n eval-AtA-times-u ] keep
] times ; inline
: spectral-norm ( n -- norm )
u/v [ v. ] keep norm-sq /f sqrt ;
@ -50,6 +46,6 @@ IN: benchmark.spectral-norm
HINTS: spectral-norm fixnum ;
: spectral-norm-main ( -- )
2000 spectral-norm . ;
5500 spectral-norm . ;
MAIN: spectral-norm-main