Merge branch 'master' of git://factorcode.org/git/factor

Makefile

@@ -1,4 +1,6 @@
 CC = gcc
+AR = ar
+LD = ld
 
 EXECUTABLE = factor
 VERSION = 0.91

core/bootstrap/image/image.factor

@@ -442,7 +442,7 @@ M: curry '
 
 PRIVATE>
 
-: make-image ( architecture -- )
+: make-image ( arch -- )
     [
         parse-hook off
         prepare-image
@@ -452,6 +452,9 @@ PRIVATE>
         image get image-name write-image
     ] with-scope ;
 
+: my-arch ( -- arch )
+    cpu dup "ppc" = [ os "-" rot 3append ] when ;
+
 : make-images ( -- )
     {
         "x86.32" "x86.64" "linux-ppc" "macosx-ppc" "arm"

core/dlists/authors.txt

@@ -1 +1,2 @@
 Mackenzie Straight
+Doug Coleman

core/dlists/dlists-docs.factor

@@ -0,0 +1,104 @@
+USING: help.markup help.syntax kernel ;
+IN: dlists
+
+ARTICLE: "dlists" "Doubly-linked lists"
+"A doubly-linked list, or dlist, is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object."
+$nl
+"While nodes can be modified directly, the fundamental protocol support by doubly-linked lists is that of a double-ended queue with a few additional operations. Elements can be added or removed at both ends of the dlist in constant time."
+$nl
+"When using a dlist as a simple queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "."
+$nl
+"Dlists form a class:"
+{ $subsection dlist }
+{ $subsection dlist? }
+"Constructing a dlist:"
+{ $subsection <dlist> }
+"Double-ended queue protocol:"
+{ $subsection dlist-empty? }
+{ $subsection push-front }
+{ $subsection pop-front }
+{ $subsection pop-front* }
+{ $subsection push-back }
+{ $subsection pop-back }
+{ $subsection pop-back* }
+"Finding out the length:"
+{ $subsection dlist-length }
+"Iterating over elements:"
+{ $subsection dlist-each }
+{ $subsection dlist-find }
+{ $subsection dlist-contains? }
+"Deleting a node matching a predicate:"
+{ $subsection delete-node* }
+{ $subsection delete-node }
+"Consuming all nodes:"
+{ $subsection dlist-slurp } ;
+
+ABOUT: "dlists"
+
+HELP: dlist-empty?
+{ $values { "dlist" { $link dlist } } { "?" "a boolean" } }
+{ $description "Returns true if a " { $link dlist } " is empty." }
+{ $notes "This operation is O(1)." } ;
+
+HELP: push-front
+{ $values { "obj" "an object" } { "dlist" dlist } }
+{ $description "Push the object onto the front of the " { $link dlist } "." } 
+{ $notes "This operation is O(1)." }
+{ $see-also push-back pop-front pop-front* pop-back pop-back* } ;
+
+HELP: push-back
+{ $values { "obj" "an object" } { "dlist" dlist } }
+{ $description "Push the object onto the back of the " { $link dlist } "." } 
+{ $notes "This operation is O(1)." }
+{ $see-also push-front pop-front pop-front* pop-back pop-back* } ;
+
+HELP: pop-front
+{ $values { "dlist" dlist } { "obj" "an object" } }
+{ $description "Pop the object off the front of the " { $link dlist } " and return the object." }
+{ $notes "This operation is O(1)." }
+{ $see-also push-front push-back pop-front* pop-back pop-back* } ;
+
+HELP: pop-front*
+{ $values { "dlist" dlist } }
+{ $description "Pop the object off the front of the " { $link dlist } "." }
+{ $notes "This operation is O(1)." }
+{ $see-also push-front push-back pop-front pop-back pop-back* } ;
+
+HELP: pop-back
+{ $values { "dlist" dlist } { "obj" "an object" } }
+{ $description "Pop the object off the back of the " { $link dlist } " and return the object." }
+{ $notes "This operation is O(1)." }
+{ $see-also push-front push-back pop-front pop-front* pop-back* } ;
+
+HELP: pop-back*
+{ $values { "dlist" dlist } }
+{ $description "Pop the object off the back of the " { $link dlist } "." }
+{ $notes "This operation is O(1)." }
+{ $see-also push-front push-back pop-front pop-front* pop-back } ;
+
+HELP: dlist-find
+{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached.  Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
+{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
+    $nl
+    "This operation is O(n)."
+} ;
+
+HELP: dlist-contains?
+{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } }
+{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
+{ $notes "This operation is O(n)." } ;
+
+HELP: delete-node*
+{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any.  Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
+{ $notes "This operation is O(n)." } ;
+
+HELP: delete-node
+{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
+{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
+{ $notes "This operation is O(n)." } ;
+
+HELP: dlist-each
+{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } }
+{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;

core/dlists/dlists-tests.factor

@@ -0,0 +1,61 @@
+USING: dlists dlists.private kernel tools.test ;
+IN: temporary
+
+[ t ] [ <dlist> dlist-empty? ] unit-test
+
+[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ]
+[ <dlist> 1 over push-front ] unit-test
+
+! Make sure empty lists are empty
+[ t ] [ <dlist> dlist-empty? ] unit-test
+[ f ] [ <dlist> 1 over push-front dlist-empty? ] unit-test
+[ f ] [ <dlist> 1 over push-back dlist-empty? ] unit-test
+
+[ 1 ] [ <dlist> 1 over push-front pop-front ] unit-test
+[ 1 ] [ <dlist> 1 over push-front pop-back ] unit-test
+[ 1 ] [ <dlist> 1 over push-back pop-front ] unit-test
+[ 1 ] [ <dlist> 1 over push-back pop-back ] unit-test
+[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-front dup pop-front* ] unit-test
+[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-front dup pop-back* ] unit-test
+[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-back dup pop-front* ] unit-test
+[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-back dup pop-back* ] unit-test
+
+! Test the prev,next links for two nodes
+[ f ] [
+    <dlist> 1 over push-back 2 over push-back
+    dlist-front dlist-node-prev
+] unit-test
+
+[ 2 ] [
+    <dlist> 1 over push-back 2 over push-back
+    dlist-front dlist-node-next dlist-node-obj
+] unit-test
+
+[ 1 ] [
+    <dlist> 1 over push-back 2 over push-back
+    dlist-front dlist-node-next dlist-node-prev dlist-node-obj
+] unit-test
+
+[ f ] [
+    <dlist> 1 over push-back 2 over push-back
+    dlist-front dlist-node-next dlist-node-next
+] unit-test
+
+[ f f ] [ <dlist> [ 1 = ] swap dlist-find ] unit-test
+[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-find ] unit-test
+[ f f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-find ] unit-test
+[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
+
+[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
+[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test
+
+[ 0 ] [ <dlist> dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
+[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test

core/dlists/dlists.factor

@@ -0,0 +1,130 @@
+! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel math ;
+IN: dlists
+
+TUPLE: dlist front back length ;
+
+: <dlist> ( -- obj )
+    dlist construct-empty
+    0 over set-dlist-length ;
+
+: dlist-empty? ( dlist -- ? ) dlist-front not ;
+
+<PRIVATE
+TUPLE: dlist-node obj prev next ;
+C: <dlist-node> dlist-node
+
+: inc-length ( dlist -- )
+    [ dlist-length 1+ ] keep set-dlist-length ; inline
+
+: dec-length ( dlist -- )
+    [ dlist-length 1- ] keep set-dlist-length ; inline
+
+: set-prev-when ( dlist-node dlist-node/f -- )
+    [ set-dlist-node-prev ] [ drop ] if* ;
+
+: set-next-when ( dlist-node dlist-node/f -- )
+    [ set-dlist-node-next ] [ drop ] if* ;
+
+: set-next-prev ( dlist-node -- )
+    dup dlist-node-next set-prev-when ;
+
+: normalize-front ( dlist -- )
+    dup dlist-back [ drop ] [ f swap set-dlist-front ] if ;
+
+: normalize-back ( dlist -- )
+    dup dlist-front [ drop ] [ f swap set-dlist-back ] if ;
+
+: set-back-to-front ( dlist -- )
+    dup dlist-back
+    [ drop ] [ dup dlist-front swap set-dlist-back ] if ;
+
+: set-front-to-back ( dlist -- )
+    dup dlist-front
+    [ drop ] [ dup dlist-back swap set-dlist-front ] if ;
+
+: (dlist-find-node) ( quot dlist-node -- node/f ? )
+    dup dlist-node-obj pick dupd call [
+        drop nip t
+    ] [
+        drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
+    ] if ;
+
+: dlist-find-node ( quot dlist -- node/f ? )
+    dlist-front [ (dlist-find-node) ] [ drop f f ] if* ;
+
+: (dlist-each-node) ( quot dlist -- )
+    over
+    [ 2dup call >r dlist-node-next r> (dlist-each-node) ]
+    [ 2drop ] if ;
+
+: dlist-each-node ( quot dlist -- )
+    >r dlist-front r> (dlist-each-node) ; inline
+PRIVATE>
+
+: push-front ( obj dlist -- )
+    [ dlist-front f swap <dlist-node> dup set-next-prev ] keep
+    [ set-dlist-front ] keep
+    [ set-back-to-front ] keep
+    inc-length ;
+
+: push-back ( obj dlist -- )
+    [ dlist-back f <dlist-node> ] keep
+    [ dlist-back set-next-when ] 2keep
+    [ set-dlist-back ] keep
+    [ set-front-to-back ] keep
+    inc-length ;
+
+: pop-front ( dlist -- obj )
+    dup dlist-front [
+        dlist-node-next
+        f over set-prev-when
+        swap set-dlist-front
+    ] 2keep dlist-node-obj
+    swap [ normalize-back ] keep dec-length ;
+
+: pop-front* ( dlist -- ) pop-front drop ;
+
+: pop-back ( dlist -- obj )
+    [
+        dlist-back dup dlist-node-prev f over set-next-when
+    ] keep
+    [ set-dlist-back ] keep
+    [ normalize-front ] keep
+    dec-length
+    dlist-node-obj ;
+
+: pop-back* ( dlist -- ) pop-back drop ;
+
+: dlist-find ( quot dlist -- obj/f ? )
+    dlist-find-node dup [ >r dlist-node-obj r> ] when ;
+
+: dlist-contains? ( quot dlist -- ? )
+    dlist-find nip ;
+
+: (delete-node) ( dlist dlist-node -- )
+    {
+        { [ 2dup >r dlist-front r> = ] [ drop pop-front* ] }
+        { [ 2dup >r dlist-back r> = ] [ drop pop-back* ] }
+        { [ t ] [ dup dlist-node-prev swap dlist-node-next set-prev-when
+                  dec-length ] }
+    } cond ;
+
+: delete-node* ( quot dlist -- obj/f ? )
+    tuck dlist-find-node [
+        [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
+    ] [
+        2drop f f
+    ] if ;
+
+: delete-node ( quot dlist -- obj/f )
+    delete-node* drop ;
+
+: dlist-each ( dlist quot -- )
+    [ dlist-node-obj ] swap compose dlist-each-node ; inline
+
+: dlist-slurp ( dlist quot -- )
+    over dlist-empty?
+    [ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ;
+    inline

core/heaps/heaps-docs.factor

@@ -0,0 +1,79 @@
+USING: heaps.private help.markup help.syntax kernel math assocs ;
+IN: heaps
+
+ARTICLE: "heaps" "Heaps"
+"A heap is an implementation of a " { $emphasis "priority queue" } ", which is a structure that maintains a sorted set of elements. The key property is that insertion of an arbitrary element and removal of the first element (determined by order) is performed in O(log n) time."
+$nl
+"Heap elements are key/value pairs and are compared using the " { $link <=> } " generic word on the first element of the pair."
+$nl
+"There are two classes of heaps. Min-heaps sort their elements so that the minimum element is first:"
+{ $subsection min-heap }
+{ $subsection min-heap? }
+{ $subsection <min-heap> }
+"Max-heaps sort their elements so that the maximum element is first:"
+{ $subsection min-heap }
+{ $subsection min-heap? }
+{ $subsection <min-heap> }
+"Both obey a protocol."
+$nl
+"Queries:"
+{ $subsection heap-empty? }
+{ $subsection heap-length }
+{ $subsection heap-peek }
+"Insertion:"
+{ $subsection heap-push }
+{ $subsection heap-push-all }
+"Removal:"
+{ $subsection heap-pop* }
+{ $subsection heap-pop } ;
+
+ABOUT: "heaps"
+
+HELP: <min-heap>
+{ $values { "min-heap" min-heap } }
+{ $description "Create a new " { $link min-heap } "." }
+{ $see-also <max-heap> } ;
+
+HELP: <max-heap>
+{ $values { "max-heap" max-heap } }
+{ $description "Create a new " { $link max-heap } "." }
+{ $see-also <min-heap> } ;
+
+HELP: heap-push
+{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } }
+{ $description "Push an pair onto a heap.  The key must be comparable with all other keys by the " { $link <=> } " generic word." }
+{ $side-effects "heap" }
+{ $see-also heap-push-all heap-pop } ;
+
+HELP: heap-push-all
+{ $values { "assoc" assoc } { "heap" heap } }
+{ $description "Push every key/value pair of an assoc onto a heap." }
+{ $side-effects "heap" }
+{ $see-also heap-push heap-pop } ;
+
+HELP: heap-peek
+{ $values { "heap" 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" heap } }
+{ $description "Removes the first element from the heap." }
+{ $side-effects "heap" }
+{ $see-also heap-pop heap-push heap-peek } ;
+
+HELP: heap-pop
+{ $values { "heap" heap } { "key" object } { "value" object } }
+{ $description "Outputs the first element in the heap and removes it from the heap." }
+{ $side-effects "heap" }
+{ $see-also heap-pop* heap-push heap-peek } ;
+
+HELP: heap-empty?
+{ $values { "heap" heap } { "?" "a boolean" } }
+{ $description "Tests if a " { $link heap } " has no nodes." }
+{ $see-also heap-length heap-peek } ;
+
+HELP: heap-length
+{ $values { "heap" heap } { "n" integer } }
+{ $description "Returns the number of key/value pairs in the heap." }
+{ $see-also heap-empty? } ;

core/heaps/heaps-tests.factor

@@ -4,29 +4,32 @@
 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 t pick 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 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
-{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test
+{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test
-{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
+{ f } [ { 5 t } { 3 t } 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 } } } ]
+[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ]
-[ <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 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test
 
-[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [
+[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [
-    <min-heap> { 3 5 4 6 5 7 6 8 } over push-heap*
+    <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } 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
+[ t 2 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick 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
+[ t 1 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick 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
+[ t 400 ] [ <max-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
+
+[ 0 ] [ <max-heap> heap-length ] unit-test
+[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test

core/heaps/heaps.factor

@@ -1,83 +1,80 @@
 ! 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
 TUPLE: heap data ;
 
-: <heap> ( -- obj )
+: <heap> ( class -- heap )
-    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 -- ? )
+GENERIC: heap-compare ( pair1 pair2 heap -- ? )
+: (heap-compare) drop [ first ] compare 0 ; inline
+M: min-heap heap-compare (heap-compare) > ;
+M: max-heap heap-compare (heap-compare) < ;
 
-M: min-heap heap-compare drop <=> 0 > ;
+: heap-bounds-check? ( m heap -- ? )
-M: max-heap heap-compare drop <=> 0 < ;
+    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 +85,29 @@ DEFER: down-heap
 
 PRIVATE>
 
-: push-heap ( obj heap -- )
+: heap-push ( value key heap -- )
-    tuck heap-data push up-heap ;
+    >r swap 2array r>
+    [ heap-data push ] keep
+    [ heap-data ] keep
+    up-heap ;
 
-: push-heap* ( seq heap -- )
+: heap-push-all ( assoc heap -- )
-    swap [ swap push-heap ] curry* each ;
+    [ swapd heap-push ] curry assoc-each ;
 
-: peek-heap ( heap -- obj )
+: heap-peek ( heap -- value key )
-    heap-data first ;
+    heap-data first first2 swap ;
 
-: 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 -- value key ) dup heap-peek rot heap-pop* ;
 
-: heap-empty? ( heap -- ? )
+: heap-empty? ( heap -- ? ) heap-data empty? ;
-    heap-data empty? ;
+
+: heap-length ( heap -- n ) heap-data length ;

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/queues/authors.txt

@@ -1 +0,0 @@
-Slava Pestov

core/queues/queues-docs.factor

@@ -1,77 +0,0 @@
-USING: help.markup help.syntax kernel ;
-IN: queues
-
-ARTICLE: "queues" "Queues"
-"Last-in-first-out queues are defined in the " { $vocab-link "queues" } " vocabulary."
-$nl
-"Queues are a class."
-{ $subsection queue }
-{ $subsection queue? }
-{ $subsection <queue> }
-"Testing queues:"
-{ $subsection queue-empty? }
-"Adding elements:"
-{ $subsection deque }
-"Removing elements:"
-{ $subsection enque }
-{ $subsection clear-queue }
-{ $subsection queue-each }
-"An example:"
-{ $code
-    "<queue> \"q\" set"
-    "5 \"q\" get enque"
-    "3 \"q\" get enque"
-    "7 \"q\" get enque"
-    "\"q\" get deque ."
-    "  5"
-    "\"q\" get deque ."
-    "  3"
-    "\"q\" get deque ."
-    "  7"
-} ;
-
-ABOUT: "queues"
-
-HELP: queue
-{ $class-description "A simple first-in-first-out queue. See " { $link "queues" } "." } ;
-
-HELP: entry
-{ $class-description "The class of entries in a " { $link queue } ". Each entry holds an object and a reference to the next entry." } ;
-
-HELP: <entry>
-{ $values { "obj" object } { "entry" entry } }
-{ $description "Creates a new queue entry." }
-{ $notes "This word is a factor of " { $link enque } "." } ;
-
-HELP: <queue>
-{ $values { "queue" queue } }
-{ $description "Makes a new queue with no elements." } ;
-
-HELP: queue-empty?
-{ $values { "queue" queue } { "?" "a boolean" } }
-{ $description "Tests if a queue contains no elements." } ;
-
-HELP: deque
-{ $values { "queue" queue } { "elt" object } }
-{ $description "Removes an element from the front of the queue." }
-{ $errors "Throws an " { $link empty-queue-error } " if the queue has no entries." }
-{ $side-effects "queue" } ;
-
-HELP: enque
-{ $values { "elt" object } { "queue" queue } }
-{ $description "Adds an element to the back of the queue." }
-{ $side-effects "queue" } ;
-
-HELP: empty-queue-error
-{ $description "Throws an " { $link empty-queue-error } "." }
-{ $error-description "Thrown by " { $link deque } " if the queue has no entries." } ;
-
-HELP: clear-queue
-{ $values { "queue" queue } }
-{ $description "Removes all entries from the queue." }
-{ $side-effects "queue" } ;
-
-HELP: queue-each
-{ $values { "queue" queue } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
-{ $description "Applies the quotation to each entry in the queue, starting from the least recently added entry, clearing the queue in the process." }
-{ $side-effects "queue" } ;

core/queues/queues-tests.factor

@@ -1,12 +0,0 @@
-USING: kernel math namespaces queues sequences tools.test ;
-IN: temporary
-
-<queue> "queue" set
-
-[ t ] [ "queue" get queue-empty? ] unit-test
-
-[ ] [ [ 1 2 3 4 5 ] [ "queue" get enque ] each ] unit-test
-
-[ { 1 2 3 4 5 } ] [ 5 [ drop "queue" get deque ] map ] unit-test
-
-[ "queue" get deque ] unit-test-fails

core/queues/queues.factor

@@ -1,57 +0,0 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: queues
-USING: kernel inspector ;
-
-TUPLE: entry obj next ;
-
-: <entry> ( obj -- entry ) f entry construct-boa ;
-
-TUPLE: queue head tail ;
-
-: <queue> ( -- queue ) queue construct-empty ;
-
-: queue-empty? ( queue -- ? ) queue-head not ;
-
-: (enque) ( entry queue -- )
-    [ set-queue-head ] 2keep set-queue-tail ;
-
-: clear-queue ( queue -- )
-    f swap (enque) ;
-
-: enque ( elt queue -- )
-    >r <entry> r> dup queue-empty? [
-        (enque)
-    ] [
-        [ queue-tail set-entry-next ] 2keep set-queue-tail
-    ] if ;
-
-: clear-entry ( entry -- )
-    f over set-entry-obj f swap set-entry-next ;
-
-: (deque) ( queue -- )
-    dup queue-head over queue-tail eq? [
-        clear-queue
-    ] [
-        dup queue-head dup entry-next rot set-queue-head
-        clear-entry
-    ] if ;
-
-TUPLE: empty-queue-error ;
-: empty-queue-error ( -- * )
-    \ empty-queue-error construct-empty throw ;
-
-: deque ( queue -- elt )
-    dup queue-empty? [
-        empty-queue-error
-    ] [
-        dup queue-head entry-obj >r (deque) r>
-    ] if ;
-
-M: empty-queue-error summary
-    drop "Empty queue" ;
-
-: queue-each ( queue quot -- )
-    over queue-empty?
-    [ 2drop ] [ [ >r deque r> call ] 2keep queue-each ] if ;
-    inline

core/queues/summary.txt

@@ -1 +0,0 @@
-FIFO queues

core/threads/threads-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax kernel kernel.private io
-threads.private continuations queues ;
+threads.private continuations dlists ;
 IN: threads
 
 ARTICLE: "threads" "Threads"
@@ -20,8 +20,8 @@ $nl
 ABOUT: "threads"
 
 HELP: run-queue
-{ $values { "queue" queue } }
+{ $values { "queue" dlist } }
-{ $description "Outputs the runnable thread queue." } ;
+{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } 
" and dequeued with " { $link pop-back } "." } ;
 
 HELP: schedule-thread
 { $values { "continuation" "a continuation reified by " { $link callcc0 } } }

core/threads/threads.factor

@@ -2,34 +2,30 @@
 ! Copyright (C) 2005 Mackenzie Straight.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: threads
-USING: arrays init hashtables heaps io.backend kernel kernel.private
+USING: arrays init hashtables heaps io.backend kernel
-math namespaces queues sequences vectors io system sorting
+kernel.private math namespaces sequences vectors io system
-continuations debugger ;
+continuations debugger dlists ;
 
 <PRIVATE
 
 SYMBOL: sleep-queue
 
-TUPLE: sleeping ms continuation ;
-
-M: sleeping <=> ( obj1 obj2 -- n )
-    [ sleeping-ms ] 2apply - ;
-
 : sleep-time ( -- ms )
-    sleep-queue get-global
+    sleep-queue get-global dup heap-empty?
-    dup heap-empty? [ drop 1000 ] [ peek-heap sleeping-ms millis [-] ] if ;
+    [ drop 1000 ] [ heap-peek nip millis [-] ] if ;
 
 : run-queue ( -- queue ) \ run-queue get-global ;
 
-: schedule-sleep ( ms continuation -- )
+: schedule-sleep ( continuation ms -- )
-    sleeping construct-boa sleep-queue get-global push-heap ;
+    sleep-queue get-global heap-push ;
 
 : wake-up ( -- continuation )
-    sleep-queue get-global pop-heap sleeping-continuation ;
+    sleep-queue get-global heap-pop drop ;
 
 PRIVATE>
 
-: schedule-thread ( continuation -- ) run-queue enque ;
+: schedule-thread ( continuation -- )
+    run-queue push-front ;
 
 : schedule-thread-with ( obj continuation -- )
     2array schedule-thread ;
@@ -38,14 +34,14 @@ PRIVATE>
     walker-hook [
         f swap continue-with
     ] [
-        run-queue deque dup array?
+        run-queue pop-back dup array?
         [ first2 continue-with ] [ continue ] if
     ] if* ;
 
 : yield ( -- ) [ schedule-thread stop ] callcc0 ;
 
 : sleep ( ms -- )
-    >fixnum millis + [ schedule-sleep stop ] callcc0 drop ;
+    >fixnum millis + [ schedule-sleep stop ] curry callcc0 ;
 
 : in-thread ( quot -- )
     [
@@ -64,10 +60,10 @@ PRIVATE>
     [ 0 ? io-multiplex ] if ;
 
 : idle-thread ( -- )
-    run-queue queue-empty? (idle-thread) yield idle-thread ;
+    run-queue dlist-empty? (idle-thread) yield idle-thread ;
 
 : init-threads ( -- )
-    <queue> \ run-queue set-global
+    <dlist> \ run-queue set-global
     <min-heap> sleep-queue set-global
     [ idle-thread ] in-thread ;
 

extra/cfdg/models/flower6/deploy.factor

@@ -0,0 +1,12 @@
+USING: tools.deploy.config ;
+V{
+    { deploy-ui? t }
+    { deploy-io 1 }
+    { deploy-reflection 2 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { "bundle-name" "cfdg.models.flower6.app" }
+}

extra/channels/channels-tests.factor

@@ -0,0 +1,44 @@
+! Copyright (C) 2005 Chris Double. All Rights Reserved.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test math channels channels.private 
+sequences threads sorting ;
+IN: temporary
+
+{ V{ 10 } } [
+    V{ } clone <channel>
+    [ from swap push ] in-thread
+    10 swap to 
+] unit-test
+
+{ 20 } [
+    <channel>
+    [ 20 swap to ] in-thread
+    from 
+] unit-test
+
+{ V{ 1 2 3 4 } } [
+    V{ } clone <channel>
+    [ from swap push ] in-thread
+    [ from swap push ] in-thread
+    [ from swap push ] in-thread
+    [ from swap push ] in-thread
+    4 over to 
+    2 over to 
+    1 over to 
+    3 swap to 
+    natural-sort
+] unit-test
+
+{ V{ 1 2 4 9 } } [
+    V{ } clone <channel>
+    [ 4 swap to ] in-thread
+    [ 2 swap to ] in-thread
+    [ 1 swap to ] in-thread
+    [ 9 swap to ] in-thread
+    2dup from swap push 
+    2dup from swap push 
+    2dup from swap push 
+    dupd from swap push 
+    natural-sort
+] unit-test

extra/channels/channels.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! Channels - based on ideas from newsqueak
-USING: kernel sequences threads continuations random math ;
+USING: kernel sequences sequences.lib threads continuations random math ;
 IN: channels
 
 TUPLE: channel receivers senders ;
@@ -15,9 +15,6 @@ GENERIC: from ( channel -- value )
 
 <PRIVATE
 
-: delete-random ( seq -- value )
-    [ length random ] keep [ nth ] 2keep delete-nth ;
-
 : wait ( channel -- )
     [ channel-senders push stop ] curry callcc0 ;
 

extra/channels/remote/remote.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! Remote Channels
-USING: kernel init namespaces assocs arrays 
+USING: kernel init namespaces assocs arrays random
 sequences channels match concurrency concurrency.distributed ;
 IN: channels.remote
 
@@ -13,7 +13,7 @@ IN: channels.remote
 PRIVATE>
 
 : publish ( channel -- id )
-    random-64 dup >r remote-channels set-at r> ;
+    random-256 dup >r remote-channels set-at r> ;
 
 : get-channel ( id -- channel )
     remote-channels at ;

extra/concurrency/concurrency.factor

@@ -26,7 +26,7 @@ TUPLE: thread timeout continuation continued? ;
     mailbox-data dlist-empty? ;
 
 : mailbox-put ( obj mailbox -- )
-    [ mailbox-data dlist-push-end ] keep
+    [ mailbox-data push-back ] keep
     [ mailbox-threads ] keep
     V{ } clone swap set-mailbox-threads
     [ thread-continuation schedule-thread ] each yield ;
@@ -51,7 +51,7 @@ TUPLE: thread timeout continuation continued? ;
 PRIVATE>
 : mailbox-get* ( mailbox timeout -- obj )
     (mailbox-block-if-empty)
-    mailbox-data dlist-pop-front ;
+    mailbox-data pop-front ;
 
 : mailbox-get ( mailbox -- obj )
     f mailbox-get* ;
@@ -59,7 +59,7 @@ PRIVATE>
 : mailbox-get-all* ( mailbox timeout -- array )
     (mailbox-block-if-empty)
     [ dup mailbox-empty? ]
-    [ dup mailbox-data dlist-pop-front ]
+    [ dup mailbox-data pop-front ]
     [ ] unfold nip ;
 
 : mailbox-get-all ( mailbox -- array )
@@ -74,7 +74,7 @@ PRIVATE>
 
 : mailbox-get?* ( pred mailbox timeout -- obj )
     2over >r >r (mailbox-block-unless-pred) r> r>
-    mailbox-data dlist-remove ; inline
+    mailbox-data delete-node ; inline
 
 : mailbox-get? ( pred mailbox -- obj )
     f mailbox-get?* ;
@@ -85,21 +85,19 @@ C: <process> process
 
 GENERIC: send ( message process -- )
 
-: random-pid ( -- id ) 8 big-random ;
-
 <PRIVATE
 : make-process ( -- process )
     #! Return a process set to run on the local node. A process is
     #! similar to a thread but can send and receive messages to and
     #! from other processes. It may also be linked to other processes so
     #! that it receives a message if that process terminates.
-    [ ] random-pid make-mailbox <process> ;
+    [ ] random-256 make-mailbox <process> ;
 
 : make-linked-process ( process -- process )
     #! Return a process set to run on the local node. That process is
     #! linked to the process on the stack. It will receive a message if
     #! that process terminates.
-    1quotation random-pid make-mailbox <process> ;
+    1quotation random-256 make-mailbox <process> ;
 PRIVATE>
 
 : self ( -- process )
@@ -206,7 +204,7 @@ MATCH-VARS: ?from ?tag ;
 <PRIVATE
 : tag-message ( message -- tagged-message )
     #! Given a message, wrap it with the sending process and a unique tag.
-    >r self random-pid r> 3array ;
+    >r self random-256 r> 3array ;
 PRIVATE>
 
 : send-synchronous ( message process -- reply )

extra/dlists/dlists-tests.factor

@@ -1,54 +0,0 @@
-IN: temporary
-USING: dlists kernel strings tools.test math ;
-
-[ "junk" ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ string? ] swap dlist-remove 
-] unit-test
-
-[ 5 20 ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ string? ] over dlist-remove drop
-  [ ] dlist-each
-] unit-test
-
-[ "junk" ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ integer? ] over dlist-remove drop
-  [ integer? ] over dlist-remove drop
-  [ ] dlist-each
-] unit-test
-
-[ t ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ string? ] swap dlist-contains?
-] unit-test
-
-[ t ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ integer? ] swap dlist-contains?
-] unit-test
-
-[ f ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ string? ] over dlist-remove drop
-  [ string? ] swap dlist-contains?
-] unit-test

extra/dlists/dlists.factor

@@ -1,100 +0,0 @@
-! Copyright (C) 2005 Mackenzie Straight.
-! See http://factorcode.org/license.txt for BSD license.
-IN: dlists
-USING: kernel math  ;
-
-! Double-linked lists.
-
-TUPLE: dlist first last ;
-
-: <dlist> dlist construct-empty ;
-
-TUPLE: dlist-node data prev next ;
-
-C: <dlist-node> dlist-node
-
-: dlist-push-end ( data dlist -- )
-    [ dlist-last f <dlist-node> ] keep
-    [ dlist-last [ dupd set-dlist-node-next ] when* ] keep
-    2dup set-dlist-last
-    dup dlist-first [ 2drop ] [ set-dlist-first ] if ;
-
-: dlist-empty? ( dlist -- ? )
-    dlist-first f = ;
-    
-: (unlink-prev) ( dlist dnode -- )
-    dup dlist-node-prev [
-        dupd swap dlist-node-next swap set-dlist-node-next
-    ] when*
-    2dup swap dlist-first eq? [ 
-        dlist-node-next swap set-dlist-first 
-    ] [ 2drop ] if ;
-
-: (unlink-next) ( dlist dnode -- )
-    dup dlist-node-next [
-        dupd swap dlist-node-prev swap set-dlist-node-prev
-    ] when*
-    2dup swap dlist-last eq? [
-        dlist-node-prev swap set-dlist-last
-    ] [ 2drop ] if ;
-
-: (dlist-unlink) ( dlist dnode -- )
-    [ (unlink-prev) ] 2keep (unlink-next) ;
-
-: (dlist-pop-front) ( dlist -- data )
-    [ dlist-first dlist-node-data ] keep dup dlist-first (dlist-unlink) ;
-
-: dlist-pop-front ( dlist -- data )
-    dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] if ;
-
-: (dlist-remove) ( dlist quot dnode -- obj/f )
-    [
-        [ dlist-node-data swap call ] 2keep rot [
-            swapd [ (dlist-unlink) ] keep dlist-node-data nip
-        ] [
-            dlist-node-next (dlist-remove)
-        ] if
-    ] [
-        2drop f
-    ] if* ; inline
-
-: dlist-remove ( quot dlist -- obj/f )
-    #! Return first item in the dlist that when passed to the
-    #! predicate quotation, true is left on the stack. The
-    #! item is removed from the dlist. The quotation
-    #! must have stack effect ( obj -- bool ).
-    #! TODO: needs a better name.
-    dup dlist-first swapd (dlist-remove) ; inline
-
-: (dlist-contains?) ( pred dnode -- bool )
-    [
-        [ dlist-node-data swap call ] 2keep rot [
-            2drop t
-        ] [
-            dlist-node-next (dlist-contains?)
-        ] if
-    ] [
-        drop f
-    ] if* ; inline
-
-: dlist-contains? ( quot dlist -- obj/f )
-    #! Return true if any item in the dlist that when passed to the
-    #! predicate quotation, true is left on the stack.
-    #! The 'pred' quotation must have stack effect ( obj -- bool ).
-    #! TODO: needs a better name.
-    dlist-first (dlist-contains?) ; inline
-
-: (dlist-each) ( quot dnode -- )
-    [
-        [ dlist-node-data swap call ] 2keep 
-        dlist-node-next (dlist-each)
-    ] [
-        drop
-    ] if* ; inline
-
-: dlist-each ( dlist quot -- )
-    swap dlist-first (dlist-each) ; inline
-
-: dlist-length ( dlist -- length )
-    0 swap [ drop 1+ ] dlist-each ;
-

extra/dlists/tags.txt

@@ -1 +0,0 @@
-collections

extra/heaps/heaps-tests.factor

@@ -1,32 +0,0 @@
-! Copyright 2007 Ryan Murphy
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel math tools.test heaps heaps.private ;
-IN: temporary
-
-[ <min-heap> pop-heap ] unit-test-fails
-[ <max-heap> pop-heap ] unit-test-fails
-
-[ t ] [ <min-heap> heap-empty? ] unit-test
-[ f ] [ <min-heap> 1 over push-heap heap-empty? ] unit-test
-[ t ] [ <max-heap> heap-empty? ] unit-test
-[ f ] [ <max-heap> 1 over push-heap 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
-{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test
-{ 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
-
-[ 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
-] 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
-
-[ 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
-
-[ 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

extra/heaps/heaps.factor

@@ -1,112 +0,0 @@
-! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
-IN: heaps
-
-<PRIVATE
-TUPLE: heap data ;
-
-: <heap> ( -- obj )
-    V{ } clone heap construct-boa ;
-PRIVATE>
-
-TUPLE: min-heap ;
-
-: <min-heap> ( -- obj )
-    <heap> min-heap construct-delegate ;
-
-TUPLE: max-heap ;
-
-: <max-heap> ( -- obj )
-    <heap> max-heap construct-delegate ;
-
-<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- ;
-
-GENERIC: heap-compare ( obj1 obj2 heap -- ? )
-
-M: min-heap heap-compare drop <=> 0 > ;
-M: max-heap heap-compare drop <=> 0 < ;
-
-: left-bounds-check? ( m heap -- ? )
-    >r left r> heap-data length >= ;
-
-: right-bounds-check? ( m heap -- ? )
-    >r right r> heap-data length >= ;
-
-: (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)
-    ] [
-        2drop
-    ] if ;
-
-: up-heap ( heap -- )
-    [ 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 [
-            right
-        ] [
-            left
-        ] if
-    ] if ;
-
-: swap-down ( m heap -- )
-    [ child ] 2keep heap-data exchange ;
-
-DEFER: down-heap
-
-: (down-heap) ( m heap -- )
-    2dup [ heap-data nth ] 2keep child pick
-    dupd [ heap-data nth swapd ] keep
-    heap-compare [
-        -rot [ swap-down ] keep down-heap
-    ] [
-        3drop
-    ] if ;
-
-: down-heap ( m heap -- )
-    2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
-
-PRIVATE>
-
-: push-heap ( obj heap -- )
-    tuck heap-data push up-heap ;
-
-: push-heap* ( seq heap -- )
-    swap [ swap push-heap ] curry* each ;
-
-: peek-heap ( heap -- obj )
-    heap-data first ;
-
-: pop-heap* ( heap -- )
-    dup heap-data length 1 > [
-        [ heap-data pop 0 ] keep
-        [ heap-data set-nth ] keep
-        >r 0 r> down-heap
-    ] [
-        heap-data pop*
-    ] if ;
-
-: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ;
-
-: heap-empty? ( heap -- ? )
-    heap-data empty? ;

extra/hello-world/deploy.factor

@@ -1,12 +1,13 @@
 USING: tools.deploy.config ;
-V{
+H{
-    { deploy-ui? f }
-    { deploy-io 3 }
-    { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-math? f }
+    { deploy-word-defs? f }
     { deploy-word-props? f }
-    { deploy-c-types? f }
-    { "stop-after-last-window?" t }
     { deploy-name "Hello world (console)" }
+    { "stop-after-last-window?" t }
+    { deploy-c-types? f }
+    { deploy-compiler? f }
+    { deploy-io 2 }
+    { deploy-ui? f }
+    { deploy-reflection 1 }
 }

extra/help/handbook/handbook.factor

@@ -122,12 +122,13 @@ ARTICLE: "collections" "Collections"
 { $heading "Associative mappings" }
 { $subsection "assocs" }
 { $subsection "namespaces" }
-{ $subsection "graphs" }
 "Implementations:"
 { $subsection "hashtables" }
 { $subsection "alists" }
 { $heading "Other collections" }
-{ $subsection "queues" }
+{ $subsection "dlists" }
+{ $subsection "heaps" }
+{ $subsection "graphs" }
 { $subsection "buffers" } ;
 
 USE: io.sockets

extra/help/markup/markup-docs.factor

@@ -100,7 +100,7 @@ HELP: $link
 { $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
 { $description "Prints a link to a help article or word." }
 { $examples
-    { $markup-example { $link "queues" } }
+    { $markup-example { $link "dlists" } }
     { $markup-example { $link + } }
 } ;
 
@@ -123,7 +123,7 @@ HELP: $see-also
 { $values { "topics" "a sequence of article names or words" } }
 { $description "Prints a heading followed by a series of links." }
 { $examples
-    { $markup-example { $see-also "graphs" "queues" } }
+    { $markup-example { $see-also "graphs" "dlists" } }
 } ;
 
 { $see-also $related related-words } related-words

extra/random/random-docs.factor

@@ -21,3 +21,11 @@ HELP: random
 { $values { "seq" "a sequence" } { "elt" "a random element" } }
 { $description "Outputs a random element of the sequence. If the sequence is empty, always outputs " { $link f } "." }
 { $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ;
+
+HELP: big-random
+{ $values { "n" "an integer" } { "r" "a random integer" } }
+{ $description "Outputs an integer with n bytes worth of bits." } ;
+
+HELP: random-256
+{ $values { "r" "a random integer" } }
+{ $description "Outputs an random integer 256 bits in length." } ;

extra/random/random.factor

@@ -93,6 +93,8 @@ PRIVATE>
 : big-random ( n -- r )
     [ drop (random) ] map >c-uint-array byte-array>bignum ;
 
+: random-256 ( -- r ) 8 big-random ; inline
+
 : random ( seq -- elt )
     dup empty? [
         drop f

extra/sequences/lib/lib-tests.factor

@@ -33,3 +33,9 @@ math.functions tools.test ;
 [ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
 [ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
 [ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
+[ f ] [ { } singleton? ] unit-test
+[ t ] [ { "asdf" } singleton? ] unit-test
+[ f ] [ { "asdf" "bsdf" } singleton? ] unit-test
+
+[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
+[ V{ } [ delete-random drop ] keep length ] unit-test-fails

extra/sequences/lib/lib.factor

@@ -1,6 +1,5 @@
 USING: combinators.lib kernel sequences math namespaces
-sequences.private shuffle ;
+random sequences.private shuffle ;
-
 IN: sequences.lib
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -61,3 +60,5 @@ IN: sequences.lib
 : singleton? ( seq -- ? )
     length 1 = ;
 
+: delete-random ( seq -- value )
+    [ length random ] keep [ nth ] 2keep delete-nth ;

extra/springies/models/belt-tire/deploy.factor

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

extra/tools/deploy/deploy-docs.factor

@@ -2,16 +2,20 @@ USING: help.markup help.syntax words alien.c-types assocs
 kernel ;
 IN: tools.deploy
 
-ARTICLE: "tools.deploy" "Stand-alone image deployment"
+ARTICLE: "tools.deploy" "Application deployment"
-"The stand-alone image deployment tool takes a vocabulary and generates an image, which when passed to the VM, runs the vocabulary's " { $link POSTPONE: MAIN: } " hook."
+"The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications."
 $nl
 "For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
-{ $code "\"hello-world\" deploy" }
+{ $code "\"hello-ui\" deploy" }
-"This generates an image file named " { $snippet "hello-world.image" } ". Now we can start this image from the operating system's command line (see " { $link "runtime-cli-args" } "):"
+"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message."
-{ $code "./factor -i=hello-world.image" "Hello world" }
+$nl
-
+"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
-"Once the necessary deployment flags have been set, a deployment image can be generated:"
+$nl
-{ $subsection deploy } ;
+"You must explicitly specify major subsystems which are required, as well as the level of reflection support needed. This is done by modifying the deployment configuration prior to deployment."
+{ $subsection "prepare-deploy" }
+"Once the necessary deployment flags have been set, the application can be deployed:"
+{ $subsection deploy }
+{ $see-also "ui.tools.deploy" } ;
 
 ABOUT: "tools.deploy"
 

extra/tools/deploy/deploy.factor

@@ -5,25 +5,30 @@ assocs kernel vocabs words sequences memory io system arrays
 continuations math definitions mirrors splitting parser classes
 inspector layouts vocabs.loader prettyprint.config prettyprint
 debugger io.streams.c io.streams.duplex io.files io.backend
-quotations io.launcher words.private tools.deploy.config ;
+quotations io.launcher words.private tools.deploy.config
+bootstrap.image ;
 IN: tools.deploy
 
 <PRIVATE
 
+: boot-image-name ( -- string )
+    "boot." my-arch ".image" 3append ;
+
+: stage1 ( -- )
+    #! If stage1 image doesn't exist, create one.
+    boot-image-name resource-path exists?
+    [ my-arch make-image ] unless ;
+
 : (copy-lines) ( stream -- stream )
     dup stream-readln [ print flush (copy-lines) ] when* ;
 
 : copy-lines ( stream -- )
     [ (copy-lines) ] [ stream-close ] [ ] cleanup ;
 
-: boot-image-name ( -- string )
-    cpu dup "ppc" = [ os "-" rot 3append ] when ;
-
 : stage2 ( vm flags -- )
 	[
-        "\"" % swap % "\" -i=boot." %
+        "\"" % swap % "\" -i=" %
-        boot-image-name
+        boot-image-name %
-        % ".image" %
         [ " " % % ] each
     ] "" make
     dup print <process-stream>
@@ -57,7 +62,7 @@ IN: tools.deploy
 PRIVATE>
 
 : deploy* ( vm image vocab config -- )
-    deploy-command-line stage2 ;
+    stage1 deploy-command-line stage2 ;
 
 SYMBOL: deploy-implementation
 

extra/tools/deploy/macosx/macosx.factor

@@ -11,6 +11,9 @@ IN: tools.deploy.macosx
 : rm ( path -- )
     "rm -rf \"" swap "\"" 3append run-process ;
 
+: chmod ( path perms -- )
+    [ "chmod " % % " \"" % % "\"" % ] "" make run-process ;
+
 : bundle-dir ( -- dir )
     vm parent-directory parent-directory ;
 
@@ -19,7 +22,9 @@ IN: tools.deploy.macosx
     >r "Contents" path+ r> path+ copy-directory ;
 
 : copy-vm ( executable bundle-name -- vm )
-    "Contents/MacOS/" path+ swap path+ vm swap [ copy-file ] keep ;
+    "Contents/MacOS/" path+ swap path+ vm swap
+    [ copy-file ] keep
+    [ "755" chmod ] keep ;
 
 : copy-fonts ( name -- )
     "fonts/" resource-path

extra/tools/deploy/shaker/shaker.factor

@@ -5,7 +5,7 @@ assocs kernel vocabs words sequences memory io system arrays
 continuations math definitions mirrors splitting parser classes
 inspector layouts vocabs.loader prettyprint.config prettyprint
 debugger io.streams.c io.streams.duplex io.files io.backend
-quotations words.private tools.deploy.config compiler ;
+quotations words.private tools.deploy.config ;
 IN: tools.deploy.shaker
 
 : show ( msg -- )
@@ -24,7 +24,7 @@ IN: tools.deploy.shaker
         "Stripping debugger" show
         "resource:extra/tools/deploy/shaker/strip-debugger.factor"
         run-file
-        recompile
+        do-parse-hook
     ] when ;
 
 : strip-libc ( -- )
@@ -32,7 +32,7 @@ IN: tools.deploy.shaker
         "Stripping manual memory management debug code" show
         "resource:extra/tools/deploy/shaker/strip-libc.factor"
         run-file
-        recompile
+        do-parse-hook
     ] when ;
 
 : strip-cocoa ( -- )
@@ -40,7 +40,7 @@ IN: tools.deploy.shaker
         "Stripping unused Cocoa methods" show
         "resource:extra/tools/deploy/shaker/strip-cocoa.factor"
         run-file
-        recompile
+        do-parse-hook
     ] when ;
 
 : strip-assoc ( retained-keys assoc -- newassoc )

extra/ui/gadgets/gadgets.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables kernel models math namespaces sequences
-timers quotations math.vectors queues combinators sorting
+timers quotations math.vectors combinators sorting vectors
-vectors ;
+dlists ;
 IN: ui.gadgets
 
 TUPLE: rect loc dim ;
@@ -159,7 +159,7 @@ M: array gadget-text*
     #! When unit testing gadgets without the UI running, the
     #! invalid queue is not initialized and we simply ignore
     #! invalidation requests.
-    invalid [ enque ] [ drop ] if* ;
+    invalid [ push-front ] [ drop ] if* ;
 
 DEFER: relayout
 

extra/ui/gestures/gestures.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math models namespaces queues
+USING: arrays assocs kernel math models namespaces
 sequences words strings system hashtables math.parser
 math.vectors tuples classes ui.gadgets timers ;
 IN: ui.gestures

extra/ui/tools/deploy/deploy-docs.factor

@@ -0,0 +1,14 @@
+USING: help.markup help.syntax ui.tools.deploy ;
+
+HELP: deploy-tool
+{ $values { "vocab" "a vocabulary specifier" } }
+{ $description "Opens the graphical deployment tool for the specified vocabulary." }
+{ $examples { $code "\"tetris\" deploy-tool" } } ;
+
+ARTICLE: "ui.tools.deploy" "Application deployment UI tool"
+"The application deployment UI tool provides a graphical front-end to deployment configuration. Using the tool, you can set deployment options graphically."
+$nl
+"To start the tool, pass a vocabulary name to a word:"
+{ $subsection deploy-tool }
+"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu."
+{ $see-also "tools.deploy" } ;

extra/ui/tools/tools-docs.factor

@@ -130,12 +130,14 @@ $nl
 { $subsection "ui-presentations" }
 { $subsection "ui-completion" }
 { $heading "Tools" }
-"All development tools are integrated into a single-window " { $emphasis "workspace" } "."
+"A single-window " { $emphasis "workspace" } " contains the most frequently-used tools:"
 { $subsection "ui-listener" }
 { $subsection "ui-browser" }
 { $subsection "ui-inspector" }
 { $subsection "ui-walker" }
 { $subsection "ui-profiler" }
+"Additional tools:"
+{ $subsection "ui.tools.deploy" }
 "Platform-specific features:"
 { $subsection "ui-cocoa" } ;
 

extra/ui/ui.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs io kernel math models namespaces
-prettyprint queues sequences threads sequences words timers
+prettyprint dlists sequences threads sequences words timers
 debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
 ui.gestures ui.backend ui.render continuations init ;
 IN: ui
@@ -81,13 +81,13 @@ SYMBOL: windows
     [
         invalid [
             dup layout find-world [ , ] when*
-        ] queue-each
+        ] dlist-slurp
     ] { } make ;
 
 SYMBOL: ui-hook
 
 : init-ui ( -- )
-    <queue> \ invalid set-global
+    <dlist> \ invalid set-global
     V{ } clone windows set-global ;
 
 : start-ui ( -- )

unmaintained/channels/channels-tests.factor

@@ -1,48 +0,0 @@
-! Copyright (C) 2005 Chris Double. All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel tools.test math channels channels.private 
-sequences threads sorting ;
-IN: temporary
-
-{ 3 t } [
-    V{ 1 2 3 4 } clone [ delete-random ] keep length swap integer?
-] unit-test
-
-{ V{ 10 } } [
-   V{ } clone <channel>
-   [ from swap push ] in-thread
-   10 swap to 
-] unit-test
-
-{ 20 } [
-   <channel>
-   [ 20 swap to ] in-thread
-   from 
-] unit-test
-
-{ V{ 1 2 3 4 } } [
-   V{ } clone <channel>
-   [ from swap push ] in-thread
-   [ from swap push ] in-thread
-   [ from swap push ] in-thread
-   [ from swap push ] in-thread
-   4 over to 
-   2 over to 
-   1 over to 
-   3 swap to 
-   [ <=> ] sort
-] unit-test
-
-{ V{ 1 2 4 9 } } [
-   V{ } clone <channel>
-   [ 4 swap to ] in-thread
-   [ 2 swap to ] in-thread
-   [ 1 swap to ] in-thread
-   [ 9 swap to ] in-thread
-   2dup from swap push 
-   2dup from swap push 
-   2dup from swap push 
-   dupd from swap push 
-   [ <=> ] sort
-] unit-test

vm/Config.linux.arm

@@ -1,2 +1,3 @@
 include vm/Config.linux
 include vm/Config.arm
+PLAF_DLL_OBJS += vm/os-linux-arm.o

vm/Config.unix

@@ -21,5 +21,5 @@ endif
 # LINKER = gcc -shared -o
 # LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor
 
-LINKER = ar rcs
+LINKER = $(AR) rcs
 LINK_WITH_ENGINE = -Wl,--whole-archive -lfactor -Wl,-no-whole-archive

vm/debug.c

@@ -200,6 +200,7 @@ void dump_objects(F_FIXNUM type)
 	{
 		if(type == -1 || type_of(obj) == type)
 		{
+			printf("%lx ",obj);
 			print_nested_obj(obj,3);
 			printf("\n");
 		}

vm/os-linux-arm.c

@@ -0,0 +1,23 @@
+#include "master.h"
+
+void flush_icache(CELL start, CELL len)
+{
+	int result;
+
+	/* XXX: why doesn't this work on Nokia n800? It should behave
+	identically to the below assembly. */
+	/* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */
+
+	__asm__ __volatile__ (
+		"mov     r0, %1\n"
+		"sub     r1, %2, #1\n"
+		"mov     r2, #0\n"
+		"swi     " __sys1(__ARM_NR_cacheflush) "\n"
+		"mov     %0, r0\n"
+		: "=r" (result)
+		: "r" (start), "r" (start + len)
+		: "r0","r1","r2");
+
+	if(result < 0)
+		critical_error("flush_icache() failed",result);
+}

vm/os-linux-arm.h

@@ -8,7 +8,7 @@ INLINE void *ucontext_stack_pointer(void *uap)
 	return (void *)ucontext->uc_mcontext.arm_sp;
 }
 
-INLINE void flush_icache(CELL start, CELL len)
+#define UAP_PROGRAM_COUNTER(ucontext) \
-{
+	(((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
-	syscall(__ARM_NR_cacheflush,start,start + len,0);
+
-}
+void flush_icache(CELL start, CELL len);