! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators fry kernel
-kernel.private locals math math.order math.private sequences
-sequences.private summary vectors ;
+USING: accessors arrays assocs fry kernel kernel.private
+math math.order math.private sequences sequences.private summary
+vectors ;
IN: heaps
GENERIC: heap-push* ( value key heap -- entry )
: <max-heap> ( -- max-heap ) max-heap <heap> ;
-M: heap heap-empty? ( heap -- ? )
- data>> empty? ; inline
+M: heap heap-empty? data>> empty? ; inline
-M: heap heap-size ( heap -- n )
- data>> length ; inline
+M: heap heap-size data>> length ; inline
<PRIVATE
M: max-heap heap-compare
drop { entry entry } declare [ key>> ] bi@ before? ; inline
-: (heapdata-compare) ( m n data heap -- ? )
- [ '[ _ data-nth ] bi@ ] [ heap-compare ] bi* ; inline
-
-: heapdata-compare ( m n heap -- ? )
- [ data>> ] keep (heapdata-compare) ; inline
-
PRIVATE>
: >entry< ( entry -- value key )
[ value>> ] [ key>> ] bi ; inline
-M: heap heap-peek ( heap -- value key )
+M: heap heap-peek
data>> first >entry< ;
<PRIVATE
+! names and optimizations inspired by cpython/Lib/heapq.py,
+! refer to it from in depth explanations of the optimizations.
+
+! called bubble-up in the literature... but we keep cpython's name.
:: sift-down ( heap from to -- )
heap data>> :> data
to data data-nth :> tmp
<PRIVATE
+! called bubble-down in the literature... but we keep cpython's name.
+! A quote from cpython's implementation:
+! > We *could* break out of the loop as soon as we find a pos where newitem <=
+! > both its children, but turns out that's not a good idea [...]
+! Indeed the code is 33% slower if we remove this optimization.
:: sift-up ( heap n -- )
heap data>> :> data
data length :> end
n dup left [ dup end < ] [
dup 1 fixnum+fast
dup end < [
- 2dup data heap (heapdata-compare)
+ 2dup [ data data-nth ] bi@ heap heap-compare
] [ f ] if
[ nip ] [ drop ] if
[ data data-nth swap data data-set-nth ]
tmp over data data-set-nth
heap n rot sift-down ; inline
-: (heap-pop*) ( heap data -- )
- [ first f >>index drop ] [ pop ] [ set-first ] tri 0 sift-up ; inline
-
PRIVATE>
M: heap heap-pop*
- dup data>> dup length 1 > [
- (heap-pop*)
- ] [
- pop f >>index 2drop
- ] if ; inline
+ dup data>> f over first index<< [ pop ] keep
+ [ 2drop ] [ set-first 0 sift-up ] if-empty ;
: heap-pop ( heap -- value key )
[ heap-peek ] [ heap-pop* ] bi ;
PRIVATE>
-: ((heap-delete)) ( n heap -- )
- 2dup [ dup up ] dip heapdata-compare
- [ swap sift-up ] [ 0 rot sift-down ] if ;
-
-: (heap-delete) ( n heap -- )
- [ nip data>> pop ]
- [ data>> data-set-nth ]
- [ ((heap-delete)) ] 2tri ;
-
-M: heap heap-delete
- [ entry>index ] [ f rot index<< ] 2bi
- {
- { [ 2dup heap-size 1 - = ] [ nip data>> pop* ] }
- { [ over zero? ] [ nip dup data>> (heap-pop*) ] }
- [ (heap-delete) ]
- } cond ;
+M:: heap heap-delete ( entry heap -- )
+ entry heap entry>index :> n
+ heap data>> :> data
+ data pop :> nth-entry
+ f entry index<<
+ n data length = [
+ nth-entry n data data-set-nth
+ n 0 = [ t ] [ nth-entry n up data data-nth heap heap-compare ] if
+ [ heap n sift-up ] [ heap 0 n sift-down ] if
+ ] unless ;
: >min-heap ( assoc -- min-heap )
dup assoc-size <vector> min-heap boa