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

slightly faster heaps, add benchmark

Slava Pestov 2009-07-18 00:52:24 -05:00
parent 9d831baa9c
commit 812c4af9a2
2 changed files with 27 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
basis/heaps/heaps.factor
View File

@ -2,7 +2,7 @@
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs sequences.private
growable accessors math.order summary ;
growable accessors math.order summary vectors ;
IN: heaps
GENERIC: heap-push* ( value key heap -- entry )
@ -15,14 +15,14 @@ GENERIC: heap-size ( heap -- n )
<PRIVATE
TUPLE: heap data ;
TUPLE: heap { data vector } ;
: <heap> ( class -- heap )
[ V{ } clone ] dip boa ; inline
TUPLE: entry value key heap index ;
: <entry> ( value key heap -- entry ) f entry boa ;
: <entry> ( value key heap -- entry ) f entry boa ; inline
PRIVATE>
@ -109,10 +109,10 @@ DEFER: up-heap
[ data-exchange ] 2keep up-heap
] [
3drop
] if ;
] if ; inline recursive
: up-heap ( n heap -- )
over 0 > [ (up-heap) ] [ 2drop ] if ;
over 0 > [ (up-heap) ] [ 2drop ] if ; inline recursive
: (child) ( m heap -- n )
2dup right-value
@ -132,10 +132,10 @@ DEFER: down-heap
3drop
] [
[ data-exchange ] 2keep down-heap
] if ;
] if ; inline recursive
: down-heap ( m heap -- )
2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; inline recursive
PRIVATE>
@ -148,7 +148,7 @@ M: heap heap-push* ( value key heap -- entry )
[ swapd heap-push ] curry assoc-each ;
: >entry< ( entry -- key value )
[ value>> ] [ key>> ] bi ;
[ value>> ] [ key>> ] bi ; inline
M: heap heap-peek ( heap -- value key )
data-first >entry< ;

19
extra/benchmark/heaps/heaps.factor Normal file
View File

@ -0,0 +1,19 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: heaps math sequences kernel ;
IN: benchmark.heaps
: data ( -- seq )
1 6000 [ 13 + 79 * 13591 mod dup ] replicate nip ;
: heap-test ( -- )
<min-heap>
data
[ [ dup pick heap-push ] each ]
[ length [ dup heap-pop* ] times ] bi
drop ;
: heap-benchmark ( -- )
100 [ heap-test ] times ;
MAIN: heap-benchmark