From 1a86c5fd8585e451aa18c84469621cc506af286f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:42:37 -0600 Subject: [PATCH] Move heaps to core/ Document heaps Renamed a lot of heaps words -- pop-heap -> heap-pop --- core/heaps/heaps-docs.factor | 41 ++++++++++++++ core/heaps/heaps-tests.factor | 20 +++---- core/heaps/heaps.factor | 102 ++++++++++++++++------------------ 3 files changed, 98 insertions(+), 65 deletions(-) create mode 100644 core/heaps/heaps-docs.factor diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor new file mode 100644 index 0000000000..a8f3d64b1e --- /dev/null +++ b/core/heaps/heaps-docs.factor @@ -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: +{ $values { "min-heap" min-heap } } +{ $description "Create a new " { $link min-heap } "." } +; + +HELP: +{ $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." } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index a8087916e7..befbbc90fc 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -4,13 +4,13 @@ USING: kernel math tools.test heaps heaps.private ; IN: temporary -[ pop-heap ] unit-test-fails -[ pop-heap ] unit-test-fails +[ heap-pop ] unit-test-fails +[ heap-pop ] unit-test-fails [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ f ] [ 1 over heap-push heap-empty? ] unit-test [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ f ] [ 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 } } } ] -[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test +[ { 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 } } } ] [ - { 3 5 4 6 5 7 6 8 } over push-heap* - 3 [ dup pop-heap* ] times + { 3 5 4 6 5 7 6 8 } over heap-push-all + 3 [ dup heap-pop* ] times ] unit-test -[ 2 ] [ 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 ] [ 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 ] [ 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 ] [ 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 ] [ 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 ] [ 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 diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 2ff9096483..74ca9e4b34 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -6,78 +6,74 @@ IN: heaps ( -- obj ) - V{ } clone heap construct-boa ; +: ( class -- obj ) + >r V{ } clone heap construct-boa r> + construct-delegate ; inline PRIVATE> TUPLE: min-heap ; -: ( -- obj ) - min-heap construct-delegate ; +: ( -- min-heap ) min-heap ; TUPLE: max-heap ; -: ( -- obj ) - max-heap construct-delegate ; +: ( -- max-heap ) max-heap ; 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? ;