steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

release
Slava Pestov 2007-11-05 15:34:03 -05:00
parent 0b4219e2f0 855c444ec5
commit 6d3d12667b
67 changed files with 686 additions and 650 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

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

5
core/bootstrap/image/image.factor
View File

@ -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"

1
extra/dlists/authors.txt → core/dlists/authors.txt
View File

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

104
core/dlists/dlists-docs.factor Normal file
View File

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

61
core/dlists/dlists-tests.factor Normal file
View File

@ -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

130
core/dlists/dlists.factor Normal file
View File

@ -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

0
extra/dlists/summary.txt → core/dlists/summary.txt
View File

0
core/queues/tags.txt → core/dlists/tags.txt
View File

79
core/heaps/heaps-docs.factor Normal file
View File

@ -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? } ;

31
core/heaps/heaps-tests.factor
View File

@ -4,29 +4,32 @@
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 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
{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
{ t } [ { 5 t } { 3 t } T{ min-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 } } } ]
[ <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{ { -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 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 } } } ] [
<min-heap> { 3 5 4 6 5 7 6 8 } over push-heap*
3 [ dup pop-heap* ] times
[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [
<min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } 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
[ 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

115
core/heaps/heaps.factor
View File

@ -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 )
V{ } clone heap construct-boa ;
: <heap> ( class -- heap )
>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 -- ? )
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 > ;
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 +85,29 @@ DEFER: down-heap
PRIVATE>
: push-heap ( obj heap -- )
tuck heap-data push up-heap ;
: heap-push ( value key heap -- )
>r swap 2array r>
[ heap-data push ] keep
[ heap-data ] keep
up-heap ;
: push-heap* ( seq heap -- )
swap [ swap push-heap ] curry* each ;
: heap-push-all ( assoc heap -- )
[ swapd heap-push ] curry assoc-each ;
: peek-heap ( heap -- obj )
heap-data first ;
: heap-peek ( heap -- value key )
heap-data first first2 swap ;
: 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-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
: heap-empty? ( heap -- ? )
heap-data empty? ;
: heap-empty? ( heap -- ? ) heap-data empty? ;
: heap-length ( heap -- n ) heap-data length ;

13
core/none/deploy.factor Normal file
View File

@ -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 }
}

1
core/queues/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

77
core/queues/queues-docs.factor
View File

@ -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" } ;

12
core/queues/queues-tests.factor
View File

@ -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

57
core/queues/queues.factor
View File

@ -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

1
core/queues/summary.txt
View File

@ -1 +0,0 @@
FIFO queues

6
core/threads/threads-docs.factor
View File

@ -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 } }
{ $description "Outputs the runnable thread queue." } ;
{ $values { "queue" dlist } }
{ $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 } } }

32
core/threads/threads.factor
View File

@ -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
math namespaces queues sequences vectors io system sorting
continuations debugger ;
USING: arrays init hashtables heaps io.backend kernel
kernel.private math namespaces sequences vectors io system
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
dup heap-empty? [ drop 1000 ] [ peek-heap sleeping-ms millis [-] ] if ;
sleep-queue get-global dup heap-empty?
[ drop 1000 ] [ heap-peek nip millis [-] ] if ;
: run-queue ( -- queue ) \ run-queue get-global ;
: schedule-sleep ( ms continuation -- )
sleeping construct-boa sleep-queue get-global push-heap ;
: schedule-sleep ( continuation ms -- )
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 ;

12
extra/cfdg/models/flower6/deploy.factor Normal file
View File

@ -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" }
}

0
unmaintained/channels/authors.txt → extra/channels/authors.txt
View File

0
unmaintained/channels/channels-docs.factor → extra/channels/channels-docs.factor
View File

44
extra/channels/channels-tests.factor Normal file
View File

@ -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

5
unmaintained/channels/channels.factor → extra/channels/channels.factor
View File

@ -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 ;

0
unmaintained/channels/examples/authors.txt → extra/channels/examples/authors.txt
View File

0
unmaintained/channels/examples/examples.factor → extra/channels/examples/examples.factor
View File

0
unmaintained/channels/examples/summary.txt → extra/channels/examples/summary.txt
View File

0
unmaintained/channels/examples/tags.txt → extra/channels/examples/tags.txt
View File

0
unmaintained/channels/remote/authors.txt → extra/channels/remote/authors.txt
View File

0
unmaintained/channels/remote/remote-docs.factor → extra/channels/remote/remote-docs.factor
View File

0
unmaintained/channels/remote/remote-tests.factor → extra/channels/remote/remote-tests.factor
View File

4
unmaintained/channels/remote/remote.factor → extra/channels/remote/remote.factor
View File

@ -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 ;

0
unmaintained/channels/remote/summary.txt → extra/channels/remote/summary.txt
View File

0
unmaintained/channels/remote/tags.txt → extra/channels/remote/tags.txt
View File

0
unmaintained/channels/sniffer/bsd/bsd.factor → extra/channels/sniffer/bsd/bsd.factor
View File

0
unmaintained/channels/sniffer/sniffer.factor → extra/channels/sniffer/sniffer.factor
View File

0
unmaintained/channels/summary.txt → extra/channels/summary.txt
View File

0
unmaintained/channels/tags.txt → extra/channels/tags.txt
View File

16
extra/concurrency/concurrency.factor
View File

@ -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 )

54
extra/dlists/dlists-tests.factor
View File

@ -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

100
extra/dlists/dlists.factor
View File

@ -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 ;

1
extra/dlists/tags.txt
View File

@ -1 +0,0 @@
collections

32
extra/heaps/heaps-tests.factor
View File

@ -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

112
extra/heaps/heaps.factor
View File

@ -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? ;

15
extra/hello-world/deploy.factor
View File

@ -1,12 +1,13 @@
USING: tools.deploy.config ;
V{
{ deploy-ui? f }
{ deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-compiler? t }
H{
{ 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 }
}

5
extra/help/handbook/handbook.factor
View File

@ -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

4
extra/help/markup/markup-docs.factor
View File

@ -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

8
extra/random/random-docs.factor
View File

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

2
extra/random/random.factor
View File

@ -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

6
extra/sequences/lib/lib-tests.factor
View File

@ -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

5
extra/sequences/lib/lib.factor
View File

@ -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 ;

13
extra/springies/models/belt-tire/deploy.factor Normal file
View File

@ -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" }
}

20
extra/tools/deploy/deploy-docs.factor
View File

@ -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"
"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."
ARTICLE: "tools.deploy" "Application deployment"
"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" }
"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" } "):"
{ $code "./factor -i=hello-world.image" "Hello world" }
"Once the necessary deployment flags have been set, a deployment image can be generated:"
{ $subsection deploy } ;
{ $code "\"hello-ui\" deploy" }
"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."
$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."
$nl
"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"

21
extra/tools/deploy/deploy.factor
View File

@ -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." %
boot-image-name
% ".image" %
"\"" % swap % "\" -i=" %
boot-image-name %
[ " " % % ] 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

7
extra/tools/deploy/macosx/macosx.factor
View File

@ -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

8
extra/tools/deploy/shaker/shaker.factor
View File

@ -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 )

6
extra/ui/gadgets/gadgets.factor
View File

@ -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
vectors ;
timers quotations math.vectors combinators sorting 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

2
extra/ui/gestures/gestures.factor
View File

@ -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

14
extra/ui/tools/deploy/deploy-docs.factor Normal file
View File

@ -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" } ;

4
extra/ui/tools/tools-docs.factor
View File

@ -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" } ;

6
extra/ui/ui.factor
View File

@ -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 ( -- )

48
unmaintained/channels/channels-tests.factor
View File

@ -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

1
vm/Config.linux.arm
View File

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

2
vm/Config.unix
View File

@ -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

1
vm/debug.c
View File

@ -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");
}

23
vm/os-linux-arm.c Normal file
View File

@ -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);
}

8
vm/os-linux-arm.h
View File

@ -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)
{
syscall(__ARM_NR_cacheflush,start,start + len,0);
}
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
void flush_icache(CELL start, CELL len);