Clean up spectral-norm
parent
e9b9172a8e
commit
8ce5760fcc
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue