Move heaps to core/

Document heaps
Renamed a lot of heaps words -- pop-heap -> heap-pop

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: <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." } ;

core/heaps/heaps-tests.factor

@@ -4,13 +4,13 @@
 USING: kernel math tools.test heaps heaps.private ;
 IN: temporary
 
-[ <min-heap> pop-heap ] unit-test-fails
+[ <min-heap> heap-pop ] unit-test-fails
-[ <max-heap> pop-heap ] 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*
+    <min-heap> { 3 5 4 6 5 7 6 8 } over heap-push-all
-    3 [ dup pop-heap* ] times
+    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

core/heaps/heaps.factor

@@ -6,78 +6,74 @@ IN: heaps
 <PRIVATE
 TUPLE: heap data ;
 
-: <heap> ( -- obj )
+: <heap> ( class -- obj )
-    V{ } clone heap construct-boa ;
+    >r V{ } clone heap construct-boa r>
+    construct-delegate ; inline
 PRIVATE>
 
 TUPLE: min-heap ;
 
-: <min-heap> ( -- obj )
+: <min-heap> ( -- min-heap ) min-heap <heap> ;
-    <heap> min-heap construct-delegate ;
 
 TUPLE: max-heap ;
 
-: <max-heap> ( -- obj )
+: <max-heap> ( -- max-heap ) max-heap <heap> ;
-    <heap> max-heap construct-delegate ;
 
 <PRIVATE
-: left ( n -- m ) 2 * 1+ ;
+: left ( n -- m ) 2 * 1+ ; inline
-: right ( n -- m ) 2 * 2 + ;
+: right ( n -- m ) 2 * 2 + ; inline
-: up ( n -- m ) 1- 2 /i ;
+: up ( n -- m ) 1- 2 /i ; inline
-: left-value ( n heap -- obj ) >r left r> nth ;
+: left-value ( n heap -- obj ) >r left r> nth ; inline
-: right-value ( n heap -- obj ) >r right r> nth ;
+: right-value ( n heap -- obj ) >r right r> nth ; inline
-: up-value ( n vec -- obj ) >r up r> nth ;
+: up-value ( n vec -- obj ) >r up r> nth ; inline
-: swap-up ( n vec -- ) >r dup up r> exchange ;
+: swap-up ( n vec -- ) >r dup up r> exchange ; inline
-: last-index ( vec -- n ) length 1- ;
+: 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 -- )
+: up-heap-continue? ( vec heap -- ? )
-    [
+    >r [ last-index ] keep [ up-value ] keep peek r>
-        >r [ last-index ] keep [ up-value ] keep peek r> heap-compare
+    heap-compare ; inline
-    ] 2keep rot [
+
-        >r dup last-index
+: up-heap ( vec heap -- )
-        [ over swap-up ] keep
+    2dup up-heap-continue?  [
-        up 1+ head-slice
+        >r dup last-index [ over swap-up ] keep
-        r> (up-heap)
+        up 1+ head-slice r> up-heap
     ] [
         2drop
     ] if ;
 
-: up-heap ( heap -- )
+: (child) ( m heap -- n )
-    [ heap-data ] keep (up-heap) ;
-
-: child ( m heap -- n )
-    2dup right-bounds-check? [
-        drop left
-    ] [
     dupd
     [ heap-data left-value ] 2keep
-        [ heap-data right-value ] keep heap-compare [
+    [ heap-data right-value ] keep heap-compare
-            right
+    [ right ] [ left ] if ;
-        ] [
+
-            left
+: child ( m heap -- n )
-        ] if
+    2dup right-bounds-check? [ drop left ] [ (child) ] if ;
-    ] 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
+    2dup down-heap-continue? [
-    dupd [ heap-data nth swapd ] keep
-    heap-compare [
         -rot [ swap-down ] keep down-heap
     ] [
         3drop
@@ -88,25 +84,21 @@ DEFER: down-heap
 
 PRIVATE>
 
-: push-heap ( obj heap -- )
+: heap-push ( obj heap -- )
-    tuck heap-data push up-heap ;
+    tuck heap-data push [ heap-data ] keep up-heap ;
 
-: push-heap* ( seq heap -- )
+: heap-push-all ( seq heap -- ) [ heap-push ] curry each ;
-    swap [ swap push-heap ] curry* each ;
 
-: peek-heap ( heap -- obj )
+: heap-peek ( heap -- obj ) heap-data first ;
-    heap-data first ;
 
-: pop-heap* ( heap -- )
+: heap-pop* ( heap -- )
     dup heap-data length 1 > [
-        [ heap-data pop 0 ] keep
+        [ heap-data pop ] keep
-        [ heap-data set-nth ] keep
+        [ heap-data set-first ] keep
-        >r 0 r> down-heap
+        0 swap down-heap
     ] [
         heap-data pop*
     ] if ;
 
-: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ;
+: heap-pop ( heap -- obj ) [ heap-data first ] keep heap-pop* ;
-
+: heap-empty? ( heap -- ? ) heap-data empty? ;
-: heap-empty? ( heap -- ? )
-    heap-data empty? ;