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

heaps: performance improvements.

db4
John Benediktsson 2013-03-06 19:41:37 -08:00
parent e008810677
commit 95c1abe468
1 changed files with 19 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
basis/heaps/heaps.factor
View File

@ -1,8 +1,10 @@
! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman, ! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
! Slava Pestov. ! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs sequences.private USING: accessors arrays assocs combinators fry growable kernel
growable accessors math.order summary vectors fry combinators ; kernel.private math math.order math.private sequences
sequences.private summary vectors ;
IN: heaps IN: heaps
GENERIC: heap-push* ( value key heap -- entry ) GENERIC: heap-push* ( value key heap -- entry )
@ -43,14 +45,17 @@ M: heap heap-size ( heap -- n )
<PRIVATE <PRIVATE
: left ( n -- m ) 1 shift 1 + ; inline : left ( n -- m )
{ fixnum } declare 1 fixnum-shift-fast 1 fixnum+fast ; inline
: right ( n -- m ) 1 shift 2 + ; inline : right ( n -- m )
{ fixnum } declare 1 fixnum-shift-fast 2 fixnum+fast ; inline
: up ( n -- m ) 1 - 2/ ; inline : up ( n -- m )
{ fixnum } declare 1 fixnum-fast 2/ ; inline
: data-nth ( n heap -- entry ) : data-nth ( n heap -- entry )
data>> nth-unsafe ; inline data>> nth-unsafe { entry } declare ; inline
: left-value ( n heap -- entry ) : left-value ( n heap -- entry )
[ left ] dip data-nth ; inline [ left ] dip data-nth ; inline
@ -155,7 +160,7 @@ M: bad-heap-delete summary
: entry>index ( entry heap -- n ) : entry>index ( entry heap -- n )
over heap>> eq? [ bad-heap-delete ] unless over heap>> eq? [ bad-heap-delete ] unless
index>> ; index>> { fixnum } declare ; inline
M: heap heap-delete ( entry heap -- ) M: heap heap-delete ( entry heap -- )
[ entry>index ] [ ] bi [ entry>index ] [ ] bi
@ -180,7 +185,12 @@ M: heap heap-pop ( heap -- value key )
[ dup heap-pop swap 2array ] [ dup heap-pop swap 2array ]
produce nip ; produce nip ;
ERROR: not-a-heap obj ;
: check-heap ( heap -- heap )
dup heap? [ not-a-heap ] unless ; inline
: slurp-heap ( heap quot: ( elt -- ) -- ) : slurp-heap ( heap quot: ( elt -- ) -- )
over heap-empty? [ 2drop ] [ [ check-heap ] dip over heap-empty? [ 2drop ] [
[ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
] if ; inline recursive ] if ; inline recursive