TUPLE: heap data ;
: <heap> ( class -- heap )
- >r V{ } clone r> boa ; inline
+ [ V{ } clone ] dip boa ; inline
TUPLE: entry value key heap index ;
data>> nth-unsafe ; inline
: up-value ( n heap -- entry )
- >r up r> data-nth ; inline
+ [ up ] dip data-nth ; inline
: left-value ( n heap -- entry )
- >r left r> data-nth ; inline
+ [ left ] dip data-nth ; inline
: right-value ( n heap -- entry )
- >r right r> data-nth ; inline
+ [ right ] dip data-nth ; inline
: data-set-nth ( entry n heap -- )
- >r [ >>index drop ] 2keep r>
- data>> set-nth-unsafe ;
+ [ [ >>index drop ] 2keep ] dip
+ data>> set-nth-unsafe ; inline
: data-push ( entry heap -- n )
dup heap-size [
data>> first ; inline
: data-exchange ( m n heap -- )
- [ tuck data-nth >r data-nth r> ] 3keep
- tuck >r >r data-set-nth r> r> data-set-nth ; inline
+ [ [ data-nth ] curry bi@ ]
+ [ [ data-set-nth ] curry bi@ ] 3bi ; inline
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
-: (heap-compare) drop [ key>> ] compare ; inline
+: (heap-compare) ( pair1 pair2 heap -- <=> )
+ drop [ key>> ] compare ; inline
M: min-heap heap-compare (heap-compare) +gt+ eq? ;
heap-size >= ; inline
: left-bounds-check? ( m heap -- ? )
- >r left r> heap-bounds-check? ; inline
+ [ left ] dip heap-bounds-check? ; inline
: right-bounds-check? ( m heap -- ? )
- >r right r> heap-bounds-check? ; inline
+ [ right ] dip heap-bounds-check? ; inline
: continue? ( m up[m] heap -- ? )
[ data-nth swap ] keep [ data-nth ] keep
DEFER: up-heap
: (up-heap) ( n heap -- )
- >r dup up r>
+ [ dup up ] dip
3dup continue? [
[ data-exchange ] 2keep up-heap
] [
: (child) ( m heap -- n )
2dup right-value
- >r 2dup left-value r>
+ [ 2dup left-value ] dip
rot heap-compare
[ right ] [ left ] if ;
: heap-pop-all ( heap -- alist )
[ dup heap-empty? not ]
[ dup heap-pop swap 2array ]
- [ ] produce nip ;
+ produce nip ;
: slurp-heap ( heap quot: ( elt -- ) -- )
over heap-empty? [ 2drop ] [
[ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
] if ; inline recursive
-
-: slurp-heap-when ( heap quot1 quot2: ( value key -- ) -- )
- pick heap-empty? [ 3drop ] [
- [ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
- [ roll [ slurp-heap-when ] [ 3drop ] if ] 3bi
- ] if ; inline recursive