! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences arrays assocs sequences.private
-growable accessors math.order summary vectors fry combinators ;
+USING: accessors arrays assocs combinators fry growable kernel
+kernel.private math math.order math.private sequences
+sequences.private summary vectors ;
+
IN: heaps
GENERIC: heap-push* ( value key heap -- entry )
<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-unsafe ; inline
+ data>> nth-unsafe { entry } declare ; inline
: left-value ( n heap -- entry )
[ left ] dip data-nth ; inline
ERROR: bad-heap-delete ;
-M: bad-heap-delete summary
+M: bad-heap-delete summary
drop "Invalid entry passed to heap-delete" ;
: entry>index ( entry heap -- n )
over heap>> eq? [ bad-heap-delete ] unless
- index>> ;
+ index>> { fixnum } declare ; inline
M: heap heap-delete ( entry heap -- )
[ entry>index ] [ ] bi
[ dup heap-pop swap 2array ]
produce nip ;
+ERROR: not-a-heap obj ;
+
+: check-heap ( heap -- heap )
+ dup heap? [ not-a-heap ] unless ; inline
+
: slurp-heap ( heap quot: ( elt -- ) -- )
- over heap-empty? [ 2drop ] [
+ [ check-heap ] dip over heap-empty? [ 2drop ] [
[ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
] if ; inline recursive