Move heaps to core/
Document heaps Renamed a lot of heaps words -- pop-heap -> heap-poprelease
Doug Coleman
parent
f301d36535
commit
1a86c5fd85
|
|
@ -0,0 +1,41 @@
|
|||
USING: heaps.private help.markup help.syntax kernel ;
|
||||
IN: heaps
|
||||
|
||||
ARTICLE: "heaps" "Heaps"
|
||||
"A heap is a data structure that obeys the heap property. A min-heap will always have its smallest member available, as a max-heap will its largest. Objects stored on the heap must be comparable using the " { $link <=> } " operator, which may mean defining a new method on an object by using " { $link POSTPONE: M: } "."
|
||||
;
|
||||
|
||||
|
||||
HELP: <min-heap>
|
||||
{ $values { "min-heap" min-heap } }
|
||||
{ $description "Create a new " { $link min-heap } "." }
|
||||
;
|
||||
|
||||
HELP: <max-heap>
|
||||
{ $values { "max-heap" max-heap } }
|
||||
{ $description "Create a new " { $link max-heap } "." }
|
||||
;
|
||||
|
||||
HELP: heap-push
|
||||
{ $values { "obj" "an object" } { "heap" "a heap" } }
|
||||
{ $description "Push an object onto a heap." } ;
|
||||
|
||||
HELP: heap-push-all
|
||||
{ $values { "seq" "a sequence" } { "heap" "a heap" } }
|
||||
{ $description "Push a sequence onto a heap." } ;
|
||||
|
||||
HELP: heap-peek
|
||||
{ $values { "heap" "a heap" } { "obj" "an object" } }
|
||||
{ $description "Returns the first element in the heap and leaves it in the heap." } ;
|
||||
|
||||
HELP: heap-pop*
|
||||
{ $values { "heap" "a heap" } }
|
||||
{ $description "Removes the first element from the heap." } ;
|
||||
|
||||
HELP: heap-pop
|
||||
{ $values { "heap" "a heap" } { "obj" "an object" } }
|
||||
{ $description "Returns the first element in the heap and removes it from the heap." } ;
|
||||
|
||||
HELP: heap-empty?
|
||||
{ $values { "heap" "a heap" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a " { $link heap } " has no nodes." } ;
|
||||
|
|
@ -4,13 +4,13 @@
|
|||
USING: kernel math tools.test heaps heaps.private ;
|
||||
IN: temporary
|
||||
|
||||
[ <min-heap> pop-heap ] unit-test-fails
|
||||
[ <max-heap> pop-heap ] unit-test-fails
|
||||
[ <min-heap> heap-pop ] unit-test-fails
|
||||
[ <max-heap> heap-pop ] unit-test-fails
|
||||
|
||||
[ t ] [ <min-heap> heap-empty? ] unit-test
|
||||
[ f ] [ <min-heap> 1 over push-heap heap-empty? ] unit-test
|
||||
[ f ] [ <min-heap> 1 over heap-push heap-empty? ] unit-test
|
||||
[ t ] [ <max-heap> heap-empty? ] unit-test
|
||||
[ f ] [ <max-heap> 1 over push-heap heap-empty? ] unit-test
|
||||
[ f ] [ <max-heap> 1 over heap-push heap-empty? ] unit-test
|
||||
|
||||
! Binary Min Heap
|
||||
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
|
||||
|
|
@ -18,15 +18,15 @@ IN: temporary
|
|||
{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
|
||||
|
||||
[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ]
|
||||
[ <min-heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test
|
||||
[ <min-heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over heap-push-all ] unit-test
|
||||
|
||||
[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [
|
||||
<min-heap> { 3 5 4 6 5 7 6 8 } over push-heap*
|
||||
3 [ dup pop-heap* ] times
|
||||
<min-heap> { 3 5 4 6 5 7 6 8 } over heap-push-all
|
||||
3 [ dup heap-pop* ] times
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test
|
||||
[ 2 ] [ <min-heap> 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push heap-pop ] unit-test
|
||||
|
||||
[ 1 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
|
||||
[ 1 ] [ <min-heap> 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test
|
||||
|
||||
[ 400 ] [ <max-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
|
||||
[ 400 ] [ <max-heap> 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,78 +6,74 @@ IN: heaps
|
|||
<PRIVATE
|
||||
TUPLE: heap data ;
|
||||
|
||||
: <heap> ( -- obj )
|
||||
V{ } clone heap construct-boa ;
|
||||
: <heap> ( class -- obj )
|
||||
>r V{ } clone heap construct-boa r>
|
||||
construct-delegate ; inline
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: min-heap ;
|
||||
|
||||
: <min-heap> ( -- obj )
|
||||
<heap> min-heap construct-delegate ;
|
||||
: <min-heap> ( -- min-heap ) min-heap <heap> ;
|
||||
|
||||
TUPLE: max-heap ;
|
||||
|
||||
: <max-heap> ( -- obj )
|
||||
<heap> max-heap construct-delegate ;
|
||||
: <max-heap> ( -- max-heap ) max-heap <heap> ;
|
||||
|
||||
<PRIVATE
|
||||
: left ( n -- m ) 2 * 1+ ;
|
||||
: right ( n -- m ) 2 * 2 + ;
|
||||
: up ( n -- m ) 1- 2 /i ;
|
||||
: left-value ( n heap -- obj ) >r left r> nth ;
|
||||
: right-value ( n heap -- obj ) >r right r> nth ;
|
||||
: up-value ( n vec -- obj ) >r up r> nth ;
|
||||
: swap-up ( n vec -- ) >r dup up r> exchange ;
|
||||
: last-index ( vec -- n ) length 1- ;
|
||||
: left ( n -- m ) 2 * 1+ ; inline
|
||||
: right ( n -- m ) 2 * 2 + ; inline
|
||||
: up ( n -- m ) 1- 2 /i ; inline
|
||||
: left-value ( n heap -- obj ) >r left r> nth ; inline
|
||||
: right-value ( n heap -- obj ) >r right r> nth ; inline
|
||||
: up-value ( n vec -- obj ) >r up r> nth ; inline
|
||||
: swap-up ( n vec -- ) >r dup up r> exchange ; inline
|
||||
: last-index ( vec -- n ) length 1- ; inline
|
||||
|
||||
GENERIC: heap-compare ( obj1 obj2 heap -- ? )
|
||||
|
||||
M: min-heap heap-compare drop <=> 0 > ;
|
||||
M: max-heap heap-compare drop <=> 0 < ;
|
||||
|
||||
: heap-bounds-check? ( m heap -- ? )
|
||||
heap-data length >= ; inline
|
||||
|
||||
: left-bounds-check? ( m heap -- ? )
|
||||
>r left r> heap-data length >= ;
|
||||
>r left r> heap-bounds-check? ; inline
|
||||
|
||||
: right-bounds-check? ( m heap -- ? )
|
||||
>r right r> heap-data length >= ;
|
||||
>r right r> heap-bounds-check? ; inline
|
||||
|
||||
: (up-heap) ( vec heap -- )
|
||||
[
|
||||
>r [ last-index ] keep [ up-value ] keep peek r> heap-compare
|
||||
] 2keep rot [
|
||||
>r dup last-index
|
||||
[ over swap-up ] keep
|
||||
up 1+ head-slice
|
||||
r> (up-heap)
|
||||
: up-heap-continue? ( vec heap -- ? )
|
||||
>r [ last-index ] keep [ up-value ] keep peek r>
|
||||
heap-compare ; inline
|
||||
|
||||
: up-heap ( vec heap -- )
|
||||
2dup up-heap-continue? [
|
||||
>r dup last-index [ over swap-up ] keep
|
||||
up 1+ head-slice r> up-heap
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: up-heap ( heap -- )
|
||||
[ heap-data ] keep (up-heap) ;
|
||||
: (child) ( m heap -- n )
|
||||
dupd
|
||||
[ heap-data left-value ] 2keep
|
||||
[ heap-data right-value ] keep heap-compare
|
||||
[ right ] [ left ] if ;
|
||||
|
||||
: child ( m heap -- n )
|
||||
2dup right-bounds-check? [
|
||||
drop left
|
||||
] [
|
||||
dupd
|
||||
[ heap-data left-value ] 2keep
|
||||
[ heap-data right-value ] keep heap-compare [
|
||||
right
|
||||
] [
|
||||
left
|
||||
] if
|
||||
] if ;
|
||||
2dup right-bounds-check? [ drop left ] [ (child) ] if ;
|
||||
|
||||
: swap-down ( m heap -- )
|
||||
[ child ] 2keep heap-data exchange ;
|
||||
|
||||
DEFER: down-heap
|
||||
|
||||
: down-heap-continue? ( heap m heap -- m heap ? )
|
||||
[ heap-data nth ] 2keep child pick
|
||||
dupd [ heap-data nth swapd ] keep heap-compare ;
|
||||
|
||||
: (down-heap) ( m heap -- )
|
||||
2dup [ heap-data nth ] 2keep child pick
|
||||
dupd [ heap-data nth swapd ] keep
|
||||
heap-compare [
|
||||
2dup down-heap-continue? [
|
||||
-rot [ swap-down ] keep down-heap
|
||||
] [
|
||||
3drop
|
||||
|
|
@ -88,25 +84,21 @@ DEFER: down-heap
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: push-heap ( obj heap -- )
|
||||
tuck heap-data push up-heap ;
|
||||
: heap-push ( obj heap -- )
|
||||
tuck heap-data push [ heap-data ] keep up-heap ;
|
||||
|
||||
: push-heap* ( seq heap -- )
|
||||
swap [ swap push-heap ] curry* each ;
|
||||
: heap-push-all ( seq heap -- ) [ heap-push ] curry each ;
|
||||
|
||||
: peek-heap ( heap -- obj )
|
||||
heap-data first ;
|
||||
: heap-peek ( heap -- obj ) heap-data first ;
|
||||
|
||||
: pop-heap* ( heap -- )
|
||||
: heap-pop* ( heap -- )
|
||||
dup heap-data length 1 > [
|
||||
[ heap-data pop 0 ] keep
|
||||
[ heap-data set-nth ] keep
|
||||
>r 0 r> down-heap
|
||||
[ heap-data pop ] keep
|
||||
[ heap-data set-first ] keep
|
||||
0 swap down-heap
|
||||
] [
|
||||
heap-data pop*
|
||||
] if ;
|
||||
|
||||
: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ;
|
||||
|
||||
: heap-empty? ( heap -- ? )
|
||||
heap-data empty? ;
|
||||
: heap-pop ( heap -- obj ) [ heap-data first ] keep heap-pop* ;
|
||||
: heap-empty? ( heap -- ? ) heap-data empty? ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue