Merge branch 'master' of git://factorcode.org/git/factor
commit
6d3d12667b
core
bootstrap/image
none
extra
cfdg/models/flower6
concurrency
hello-world
help
handbook
markup
sequences/lib
springies/models/belt-tire
tools/deploy
ui
unmaintained/channels
|
@ -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 +1,2 @@
|
|||
Mackenzie Straight
|
||||
Doug Coleman
|
|
@ -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." } ;
|
|
@ -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
|
|
@ -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,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? } ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 +0,0 @@
|
|||
Slava Pestov
|
|
@ -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" } ;
|
|
@ -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
|
|
@ -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 +0,0 @@
|
|||
FIFO queues
|
|
@ -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 } } }
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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,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
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
|
@ -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 +0,0 @@
|
|||
collections
|
|
@ -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
|
|
@ -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? ;
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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" }
|
||||
}
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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" } ;
|
|
@ -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" } ;
|
||||
|
||||
|
|
|
@ -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 ( -- )
|
||||
|
|
|
@ -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,2 +1,3 @@
|
|||
include vm/Config.linux
|
||||
include vm/Config.arm
|
||||
PLAF_DLL_OBJS += vm/os-linux-arm.o
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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");
|
||||
}
|
||||
|
|
|
@ -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,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);
|
||||
|
|
Loading…
Reference in New Issue