Further heap cleanups

core/heaps/heaps-docs.factor

@@ -1,4 +1,4 @@
-USING: heaps.private help.markup help.syntax kernel ;
+USING: heaps.private help.markup help.syntax kernel math ;
 IN: heaps
 
 ARTICLE: "heaps" "Heaps"
@@ -40,36 +40,36 @@ HELP: <max-heap>
 { $see-also <min-heap> } ;
 
 HELP: heap-push
-{ $values { "pair" "a key/value pair" } { "heap" "a heap" } }
-{ $description "Push an pair onto a heap.  The first element of the pair must be comparable to the rest of the heap by the " { $link <=> } " word." }
+{ $values { "key" "a comparable object" } { "value" object } { "heap"  } }
+{ $description "Push an pair onto a heap.  The key must be comparable with all other keys by the " { $link <=> } " generic word." }
 { $see-also heap-push-all heap-pop } ;
 
 HELP: heap-push-all
-{ $values { "seq" "a sequence of pairs" } { "heap" "a heap" } }
+{ $values { "seq" "a sequence of pairs" } { "heap"  } }
 { $description "Push a sequence of pairs onto a heap." }
 { $see-also heap-push heap-pop } ; 
 
 HELP: heap-peek
-{ $values { "heap" "a heap" } { "pair" "a key/value pair" } }
-{ $description "Returns the first element in the heap and leaves it in the heap." }
+{ $values { "heap"  } { "key" object } { "value" object } }
+{ $description "Outputs the first element in the heap, leaving it in the heap." }
 { $see-also heap-pop heap-pop* } ;
 
 HELP: heap-pop*
-{ $values { "heap" "a heap" } }
+{ $values { "heap"  } }
 { $description "Removes the first element from the heap." }
 { $see-also heap-pop heap-push heap-peek } ;
 
 HELP: heap-pop
-{ $values { "heap" "a heap" } { "pair" "an key/value pair" } }
-{ $description "Returns the first element in the heap and removes it from the heap." }
+{ $values { "heap"  } { "key" object } { "value" object } }
+{ $description "Outputs the first element in the heap and removes it from the heap." }
 { $see-also heap-pop* heap-push heap-peek } ;
 
 HELP: heap-empty?
-{ $values { "heap" "a heap" } { "?" "a boolean" } }
+{ $values { "heap"  } { "?" "a boolean" } }
 { $description "Tests if a " { $link heap } " has no nodes." }
 { $see-also heap-length heap-peek } ;
 
 HELP: heap-length
-{ $values { "heap" "a heap" } { "n" "an integer" } }
+{ $values { "heap"  } { "n" integer } }
 { $description "Returns the number of key/value pairs in the heap." }
 { $see-also heap-empty? } ;

core/heaps/heaps-tests.factor

@@ -8,9 +8,9 @@ IN: temporary
 [ <max-heap> heap-pop ] unit-test-fails
 
 [ t ] [ <min-heap> heap-empty? ] unit-test
-[ f ] [ <min-heap> { 1 t } over heap-push heap-empty? ] unit-test
+[ f ] [ <min-heap> 1 t pick heap-push heap-empty? ] unit-test
 [ t ] [ <max-heap> heap-empty? ] unit-test
-[ f ] [ <max-heap> { 1 t } over heap-push heap-empty? ] unit-test
+[ f ] [ <max-heap> 1 t pick 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
@@ -25,11 +25,11 @@ IN: temporary
     3 [ dup heap-pop* ] times
 ] unit-test
 
-[ { 2 t } ] [ <min-heap> { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push heap-pop ] unit-test
+[ 2 t ] [ <min-heap> 300 t pick heap-push 200 t pick heap-push 400 t pick heap-push 3 t pick heap-push 2 t pick heap-push heap-pop ] unit-test
 
-[ { 1 t } ] [ <min-heap> { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test
+[ 1 t ] [ <min-heap> 300 300 pick heap-push 200 200 pick heap-push 400 400 pick heap-push 3 3 pick heap-push 2 2 pick heap-push 1 1 pick heap-push heap-pop ] unit-test
 
-[ { 400 t } ] [ <max-heap> { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test
+[ 400 t ] [ <max-heap> 300 300 pick heap-push 200 200 pick heap-push 400 400 pick heap-push 3 3 pick heap-push 2 2 pick heap-push 1 1 pick heap-push heap-pop ] unit-test
 
 [ 0 ] [ <max-heap> heap-length ] unit-test
-[ 1 ] [ <max-heap> { 1 t } over heap-push heap-length ] unit-test
+[ 1 ] [ <max-heap> 1 1 pick heap-push heap-length ] unit-test

core/heaps/heaps.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel math sequences arrays assocs ;
 IN: heaps
 
 <PRIVATE
@@ -30,13 +30,13 @@ TUPLE: max-heap ;
 : last-index ( vec -- n ) length 1- ; inline
 
 GENERIC: heap-compare ( pair1 pair2 heap -- ? )
-: (heap-compare) drop [ first ] 2apply <=> 0 ; inline
+: (heap-compare) drop [ first ] compare 0 ; inline
 M: min-heap heap-compare (heap-compare) > ;
 M: max-heap heap-compare (heap-compare) < ;
 
 : heap-bounds-check? ( m heap -- ? )
     heap-data length >= ; inline
-    
+
 : left-bounds-check? ( m heap -- ? )
     >r left r> heap-bounds-check? ; inline
 
@@ -72,7 +72,7 @@ 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 down-heap-continue? [
         -rot [ swap-down ] keep down-heap
@@ -85,12 +85,17 @@ DEFER: down-heap
 
 PRIVATE>
 
-: heap-push ( pair heap -- )
-    tuck heap-data push [ heap-data ] keep up-heap ;
+: heap-push ( value key heap -- )
+    >r swap 2array r>
+    [ heap-data push ] keep
+    [ heap-data ] keep
+    up-heap ;
 
-: heap-push-all ( seq heap -- ) [ heap-push ] curry each ;
+: heap-push-all ( assoc heap -- )
+    [ swap heap-push ] curry assoc-each ;
 
-: heap-peek ( heap -- pair ) heap-data first ;
+: heap-peek ( heap -- value key )
+    heap-data first first2 swap ;
 
 : heap-pop* ( heap -- )
     dup heap-data length 1 > [
@@ -101,6 +106,16 @@ PRIVATE>
         heap-data pop*
     ] if ;
 
-: heap-pop ( heap -- pair ) [ heap-data first ] keep heap-pop* ;
+: heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
+
 : heap-empty? ( heap -- ? ) heap-data empty? ;
+
 : heap-length ( heap -- n ) heap-data length ;
+
+: heap-pop-all ( heap -- seq )
+    [ dup heap-empty? not ]
+    [ dup heap-pop drop ] 
+    [ ] unfold nip ;
+
+: heap-sort ( assoc -- seq )
+    <min-heap> tuck heap-push-all heap-pop-all ;

core/none/deploy.factor

@@ -0,0 +1,13 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-math? f }
+    { deploy-word-defs? f }
+    { deploy-word-props? f }
+    { deploy-name "none" }
+    { "stop-after-last-window?" t }
+    { deploy-c-types? f }
+    { deploy-compiler? f }
+    { deploy-io 1 }
+    { deploy-ui? f }
+    { deploy-reflection 1 }
+}

core/threads/threads.factor

@@ -12,19 +12,20 @@ SYMBOL: sleep-queue
 
 : sleep-time ( -- ms )
     sleep-queue get-global dup heap-empty?
-    [ drop 1000 ] [ heap-peek first millis [-] ] if ;
+    [ drop 1000 ] [ heap-peek nip millis [-] ] if ;
 
 : run-queue ( -- queue ) \ run-queue get-global ;
 
-: schedule-sleep ( ms continuation -- )
-    2array sleep-queue get-global heap-push ;
+: schedule-sleep ( continuation ms -- )
+    sleep-queue get-global heap-push ;
 
 : wake-up ( -- continuation )
-    sleep-queue get-global heap-pop second ;
+    sleep-queue get-global heap-pop drop ;
 
 PRIVATE>
 
-: schedule-thread ( continuation -- ) run-queue push-front ;
+: schedule-thread ( continuation -- )
+    run-queue push-front ;
 
 : schedule-thread-with ( obj continuation -- )
     2array schedule-thread ;
@@ -40,7 +41,7 @@ PRIVATE>
 : yield ( -- ) [ schedule-thread stop ] callcc0 ;
 
 : sleep ( ms -- )
-    >fixnum millis + [ schedule-sleep stop ] callcc0 drop ;
+    >fixnum millis + [ schedule-sleep stop ] curry callcc0 ;
 
 : in-thread ( quot -- )
     [