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

Merge commit 'erg/master'

release
Slava Pestov 2007-11-01 19:51:57 -04:00
parent 8c87610fc6 688ccb8a14
commit 59f197df9a
19 changed files with 281 additions and 419 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
core/threads/threads.factor
View File

@ -2,7 +2,7 @@
! Copyright (C) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
IN: threads
USING: arrays init hashtables io.backend kernel kernel.private
USING: arrays init hashtables heaps io.backend kernel kernel.private
math namespaces queues sequences vectors io system sorting
continuations debugger ;
@ -10,21 +10,22 @@ continuations debugger ;
SYMBOL: sleep-queue
TUPLE: sleeping ms continuation ;
M: sleeping <=> ( obj1 obj2 -- n )
[ sleeping-ms ] 2apply - ;
: sleep-time ( -- ms )
sleep-queue get-global
dup empty? [ drop 1000 ] [ first first millis [-] ] if ;
dup heap-empty? [ drop 1000 ] [ peek-heap sleeping-ms millis [-] ] if ;
: run-queue ( -- queue ) \ run-queue get-global ;
: schedule-sleep ( ms continuation -- )
2array global [
sleep-queue [ swap add sort-keys ] change
] bind ;
sleeping construct-boa sleep-queue get-global push-heap ;
: wake-up ( -- continuation )
global [
sleep-queue [ unclip second swap ] change
] bind ;
sleep-queue get-global pop-heap sleeping-continuation ;
PRIVATE>
@ -67,9 +68,8 @@ PRIVATE>
: init-threads ( -- )
<queue> \ run-queue set-global
f sleep-queue set-global
<min-heap> sleep-queue set-global
[ idle-thread ] in-thread ;
[ init-threads ] "threads" add-init-hook
PRIVATE>

8
extra/calendar/calendar-tests.factor
View File

@ -126,16 +126,16 @@ continuations system ;
2004 1 1 13 30 0 0 make-timestamp = ] unit-test
[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp
2004 1 1 12 30 0 -1 make-timestamp compare-timestamps ] unit-test
2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test
[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp
2004 1 1 12 30 0 0 make-timestamp compare-timestamps ] unit-test
2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test
[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp
2004 1 1 13 30 0 0 make-timestamp compare-timestamps ] unit-test
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp
2004 1 1 13 30 0 0 make-timestamp compare-timestamps ] unit-test
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test
[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test

2
extra/calendar/calendar.factor
View File

@ -205,7 +205,7 @@ M: number +second ( timestamp n -- timestamp )
: >gmt ( timestamp -- timestamp )
0 convert-timezone ;
: compare-timestamps ( tuple tuple -- n )
M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ;
: timestamp- ( timestamp timestamp -- seconds )

83
extra/concurrency/concurrency.factor
View File

@ -5,11 +5,20 @@
! concurrency.
USING: vectors dlists threads sequences continuations
namespaces random math quotations words kernel match
arrays io assocs init ;
arrays io assocs init shuffle system ;
IN: concurrency
TUPLE: mailbox threads data ;
TUPLE: thread timeout continuation continued? ;
: <thread> ( timeout continuation -- obj )
>r dup [ millis + ] when r>
{
set-thread-timeout
set-thread-continuation
} thread construct ;
: make-mailbox ( -- mailbox )
V{ } clone <dlist> mailbox construct-boa ;
@ -18,34 +27,44 @@ TUPLE: mailbox threads data ;
: mailbox-put ( obj mailbox -- )
[ mailbox-data dlist-push-end ] keep
[ mailbox-threads ] keep 0 <vector> swap set-mailbox-threads
[ schedule-thread ] each yield ;
[ mailbox-threads ] keep
V{ } clone swap set-mailbox-threads
[ thread-continuation schedule-thread ] each yield ;
<PRIVATE
: (mailbox-block-unless-pred) ( pred mailbox -- )
2dup mailbox-data dlist-contains? [
2drop
: (mailbox-block-unless-pred) ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [
3drop
] [
[ swap mailbox-threads push stop ] callcc0
[ <thread> swap mailbox-threads push stop ] callcc0
(mailbox-block-unless-pred)
] if ; inline
: (mailbox-block-if-empty) ( mailbox -- mailbox2 )
dup mailbox-empty? [
[ swap mailbox-threads push stop ] callcc0
: (mailbox-block-if-empty) ( mailbox timeout -- mailbox2 )
over mailbox-empty? [
[ <thread> swap mailbox-threads push stop ] callcc0
"(mailbox-block-if-empty)" print flush
(mailbox-block-if-empty)
] when ;
] [
drop
] if ;
PRIVATE>
: mailbox-get ( mailbox -- obj )
: mailbox-get* ( mailbox timeout -- obj )
(mailbox-block-if-empty)
mailbox-data dlist-pop-front ;
: mailbox-get-all ( mailbox -- array )
: mailbox-get ( mailbox -- obj )
f mailbox-get* ;
: mailbox-get-all* ( mailbox timeout -- array )
(mailbox-block-if-empty)
[ dup mailbox-empty? ]
[ dup mailbox-data dlist-pop-front ]
{ } unfold ;
: mailbox-get-all ( mailbox -- array )
f mailbox-get-all* ;
: while-mailbox-empty ( mailbox quot -- )
over mailbox-empty? [
dup >r swap slip r> while-mailbox-empty
@ -53,10 +72,12 @@ PRIVATE>
2drop
] if ; inline
: mailbox-get?* ( pred mailbox timeout -- obj )
2over >r >r (mailbox-block-unless-pred) r> r>
mailbox-data dlist-remove ; inline
: mailbox-get? ( pred mailbox -- obj )
2dup (mailbox-block-unless-pred)
mailbox-data dlist-remove ;
inline
f mailbox-get?* ;
TUPLE: process links pid mailbox ;
@ -64,9 +85,7 @@ C: <process> process
GENERIC: send ( message process -- )
: random-64 ( -- id )
#! Generate a random id to use for pids
"ID" 64 [ drop 10 random CHAR: 0 + ] map append ;
: random-pid ( -- id ) 8 big-random ;
<PRIVATE
: make-process ( -- process )
@ -74,13 +93,13 @@ GENERIC: send ( message process -- )
#! 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-64 make-mailbox <process> ;
[ ] random-pid 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-64 make-mailbox <process> ;
1quotation random-pid make-mailbox <process> ;
PRIVATE>
: self ( -- process )
@ -187,7 +206,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-64 r> 3array ;
>r self random-pid r> 3array ;
PRIVATE>
: send-synchronous ( message process -- reply )
@ -286,23 +305,29 @@ TUPLE: promise fulfilled? value processes ;
[ set-promise-value ] keep
[ t swap set-promise-fulfilled? ] keep
[ promise-processes ] keep
0 <vector> swap set-promise-processes
[ schedule-thread ] each yield
V{ } clone swap set-promise-processes
[ thread-continuation schedule-thread ] each yield
] if ;
<PRIVATE
: (maybe-block-promise) ( promise -- promise )
: (maybe-block-promise) ( promise timeout -- promise )
#! Block the process if the promise is unfulfilled. This is different from
#! (mailbox-block-if-empty) in that when a promise is fulfilled, all threads
#! need to be resumed, rather than just one.
dup promise-fulfilled? [
[ swap promise-processes push stop ] callcc0
] unless ;
over promise-fulfilled? [
drop
] [
[ <thread> swap promise-processes push stop ] callcc0
drop
] if ;
PRIVATE>
: ?promise ( promise -- result )
: ?promise* ( promise timeout -- result )
(maybe-block-promise) promise-value ;
: ?promise ( promise -- result )
f ?promise* ;
! ******************************
! Experimental code below
! ******************************

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

@ -0,0 +1,32 @@
! 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 Normal file
View File

@ -0,0 +1,112 @@
! 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? ;

5
extra/http/server/responders/callback/callback.factor
View File

@ -2,8 +2,7 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: html http http.server.responders io kernel math namespaces
continuations random system sequences assocs ;
prettyprint continuations random system sequences assocs ;
IN: http.server.responders.callback
#! Name of the variable holding the continuation used to exit
@ -58,7 +57,7 @@ TUPLE: request stream exitcc method url raw-query query header response ;
: get-random-id ( -- id )
#! Generate a random id to use for continuation URL's
"ID" 32 [ drop 9 random CHAR: 0 + ] map append ;
4 big-random unparse ;
: callback-table ( -- <hashtable> )
#! Return the global table of continuations

4
extra/roman/roman-tests.factor
View File

@ -1,9 +1,5 @@
USING: arrays kernel math roman roman.private sequences tools.test ;
[ { { 1 } { -1 5 } { 2 4 } } ]
[ { 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
[ "i" ] [ 1 >roman ] unit-test
[ "ii" ] [ 2 >roman ] unit-test
[ "iii" ] [ 3 >roman ] unit-test

12
extra/roman/roman.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.vectors namespaces
quotations sequences sequences.private strings ;
quotations sequences sequences.lib sequences.private strings ;
IN: roman
<PRIVATE
@ -22,16 +22,6 @@ TUPLE: roman-range-error n ;
roman-range-error construct-boa throw
] if ;
: ,, building get peek push ;
: v, V{ } clone , ;
: ,v building get dup peek empty? [ dup pop* ] when drop ;
: monotonic-split ( seq quot -- newseq )
[
>r dup unclip add r>
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ;
: roman<= ( ch1 ch2 -- ? )
[ 1string roman-digits index ] 2apply >= ;

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

@ -1,4 +1,5 @@
USING: kernel sequences.lib math math.functions tools.test ;
USING: arrays kernel sequences sequences.lib math
math.functions tools.test ;
[ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
[ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
@ -28,3 +29,7 @@ USING: kernel sequences.lib math math.functions tools.test ;
[ -11 -9 ] [ { -11 -10 -9 } minmax ] unit-test
[ -1/0. 1/0. ] [ { -1/0. 1/0. -11 -10 -9 } minmax ] unit-test
[ { { 1 } { -1 5 } { 2 4 } } ]
[ { 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

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

@ -1,4 +1,4 @@
USING: combinators.lib kernel sequences math
USING: combinators.lib kernel sequences math namespaces
sequences.private shuffle ;
IN: sequences.lib
@ -46,3 +46,18 @@ IN: sequences.lib
#! find the min and max of a seq in one pass
1/0. -1/0. rot [ tuck max >r min r> ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ,, building get peek push ;
: v, V{ } clone , ;
: ,v building get dup peek empty? [ dup pop* ] when drop ;
: monotonic-split ( seq quot -- newseq )
[
>r dup unclip add r>
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ;
: singleton? ( seq -- ? )
length 1 = ;

41
extra/store/store-tests.factor Normal file
View File

@ -0,0 +1,41 @@
USING: assocs continuations debugger io.files kernel
namespaces store tools.test ;
IN: temporary
SYMBOL: store
SYMBOL: foo
SYMBOL: bar
: the-store ( -- path )
"store-test.store" resource-path ;
: delete-the-store ( -- )
[ the-store delete-file ] catch drop ;
: load-the-store ( -- )
the-store load-store store set ;
: save-the-store ( -- )
store get save-store ;
delete-the-store
the-store load-store store set
[ f ] [ foo store get store-data at ] unit-test
[ ] [ 100 foo store get store-variable ] unit-test
[ ] [ save-the-store ] unit-test
[ 100 ] [ foo store get store-data at ] unit-test
1000 foo set
[ ] [ save-the-store ] unit-test
[ ] [ load-the-store ] unit-test
[ 1000 ] [ foo store get store-data at ] unit-test
delete-the-store

5
extra/store/store.factor
View File

@ -11,12 +11,12 @@ C: <store> store
[ store-data ] keep store-path <file-writer> [
[
dup
[ drop [ get ] keep rot set-at ] curry* assoc-each
[ >r drop [ get ] keep r> set-at ] curry assoc-each
] keep serialize
] with-stream ;
: load-store ( path -- store )
resource-path dup exists? [
dup exists? [
dup <file-reader> [
deserialize
] with-stream
@ -30,4 +30,3 @@ C: <store> store
] [
drop >r 2dup set-global r> set-at
] if ;

74
unmaintained/heap/heap.factor
View File

@ -1,74 +0,0 @@
! Binary Min Heap
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences ;
IN: heap
: [comp] ( elt elt -- ? ) <=> 0 > ;
: <heap> ( -- heap ) V{ } clone ;
: left ( index -- index ) ! left child
2 * 1 + ;
: leftv ( heap index -- value )
left swap nth ;
: right ( index -- index ) ! right child
2 * 2 + ;
: rightv ( heap index -- value )
right swap nth ;
: l-oob ( i heap -- ? ) swap left swap length >= ;
: r-oob ( i heap -- ? ) swap right swap length >= ;
: up ( index -- index ) ! parent node
1 - 2 /i ;
: upv ( heap index -- value ) ! parent's value
up swap nth ;
: lasti ( seq -- index ) length 1 - ;
: swapup ( heap index -- ) dup up rot exchange ;
: (farchild) ( heap index -- index ) tuck 2dup leftv -rot rightv [comp] [ right ] [ left ] if ;
: farchild ( heap index -- index ) dup right pick length >= [ nip left ] [ (farchild) ] if ;
: farchildv ( heap index -- value ) dupd farchild swap nth ;
: swapdown ( heap index -- ) 2dup farchild rot exchange ;
: upheap ( heap -- )
dup dup lasti upv over peek [comp]
[ dup lasti 2dup swapup up 1 + head-slice upheap ] [ drop ] if ;
: add ( elt heap -- )
tuck push upheap ;
: add-many ( seq heap -- )
swap [ swap add ] each-with ;
DEFER: (downheap)
: (downheap2) ( i heap -- )
2dup nth -rot
2dup swap farchild dup pick nth 2swap
>r >r
swapd [comp]
[ r> r> tuck swap swapdown (downheap) ] [ drop r> r> 2drop ] if ;
: (downheap) ( i heap -- )
over left over length >= [ 2drop ] [ (downheap2) ] if ;
: downheap ( heap -- )
0 swap (downheap) ;
: bump ( heap -- )
dup peek 0 pick set-nth dup pop* downheap ;
: gbump ( heap -- first )
dup first swap bump ;

76
unmaintained/heap/heap.facts
View File

@ -1,76 +0,0 @@
! Binary Min Heap
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
USING: help heap sequences ;
ARTICLE: { "heap" "heap" } "Binary Min Heap"
"A vector-based implementation of a binary min heap. Elements are simply stored in a vector, so use " { $link first } " to access the root of the heap."
{ $subsection <heap> }
{ $subsection add }
{ $subsection add-many }
{ $subsection bump }
{ $subsection gbump }
{ $subsection print-heap }
;
HELP: <heap>
"Creates a new heap with nothing on it." ;
HELP: add
"Adds 1 element to the heap."
{ $examples
{ $code
"USE: heap"
"<heap> 3 over add 4 over add 5 over add"
"print-heap"
}
}
;
HELP: add-many
"For each element in the sequence, add it to the heap."
{ $examples
{ $code
"USE: heap"
"<heap> { 7 6 5 4 3 2 1 } over add-many"
"print-heap"
}
}
;
HELP: bump
"\"Bumps\" the root element off of the heap, rearranging the remaining elements so that the heap remains valid."
{ $examples
{ $code
"USE: heap"
"<heap> { 7 6 5 4 3 2 1 } over add-many"
"dup print-heap"
"dup bump \"(bump)\" print dup print-heap"
"dup bump \"(bump)\" print dup print-heap"
"dup bump \"(bump)\" print dup print-heap"
}
}
;
HELP: gbump
"(\"Get-bump\") Does a " { $link bump } ", but leaves the bumped element on the stack instead of discarding it."
{ $examples
{ $code
"USE: heap"
"<heap> { 7 6 5 4 3 2 1 } over add-many"
"dup gbump"
}
}
;
HELP: print-heap
"Prints the heap in tree form."
{ $examples
{ $code
"USE: heap"
"<heap> { 7 6 5 4 3 2 1 } over add-many"
"print-heap"
}
}
;

100
unmaintained/heap/human tests.factor
View File

@ -1,100 +0,0 @@
: test-agg2 ( -- )
{
} >vector
{
"bbbbbbb"
"bbbbbbb"
} >vector
aggregate2 [ print ] each "" print
{
"aa"
"aa"
} >vector
{
} >vector
aggregate2 [ print ] each "" print
{
} >vector
{
} >vector
aggregate2 [ print ] each "" print
{
"aaaaaaa"
"aaaaaaa"
"aaaaaaa"
"aaaaaaa"
"aaaaaaa"
"aaaaaaa"
} >vector
{
"bbbb"
"bbbb"
"bbbb"
} >vector
aggregate2 [ print ] each "" print
{
"aaaa"
"aaaa"
"aaaa"
} >vector
{
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
} >vector
aggregate2 [ print ] each "" print
;
: test-agg ( -- )
{
"....5.."
"...|.|."
"..7...9"
".|....."
"8......"
} >vector
{
"..3.."
".|.|."
"4...4"
} >vector
{
".2."
"|.|"
} >vector
aggregate3 [ print ] each "" print
{
"....5.."
"...|.|."
"..7...9"
".|....."
"8......"
} >vector
{
"......3...."
".....|.|..."
"....4...4.."
"...|.|....."
"..5...6...."
".|........."
"6.........."
} >vector
{
".2."
"|.|"
} >vector
aggregate3 [ print ] each "" print
;

16
unmaintained/heap/load.factor
View File

@ -1,16 +0,0 @@
! Binary Min Heap
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
PROVIDE: libs/heap
{ +files+ {
"heap.factor"
"print.factor"
"heap.facts"
} }
{ +tests+ {
"tests.factor"
} } ;

51
unmaintained/heap/print.factor
View File

@ -1,51 +0,0 @@
! Binary Min Heap
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel math sequences prettyprint io ;
IN: heap
: spaces ( n -- str )
[ [ " " % ] times ] "" make ;
: prepend-s ( v1 n -- v1' )
spaces swap [ append ] map-with ;
: append-s ( v1 v2 -- v1' )
spaces swap [ swap append ] map-with ;
: pad-r ( lv rv -- rv' )
dup first length spaces pick length pick length -
[ [ dup , ] times ] V{ } make
nip append nip ;
: pad-l ( lv rv -- lv' )
swap pad-r ;
: (aggregate2) ( lv rv -- v )
over length over length >= [ dupd pad-r ] [ tuck pad-l swap ] if
[ append ] 2map ;
: aggregate2 ( lv rv -- v )
dup empty? [ drop ] [ over empty? [ nip ] [ (aggregate2) ] if ] if ;
: (agg3len) ( v -- len )
dup empty? [ drop 0 ] [ first length ] if ;
: aggregate3 ( lv rv pv -- v )
dup (agg3len) -roll
pick (agg3len) prepend-s
over (agg3len) append-s
-roll -rot swap append-s
swap aggregate2 append ;
: output-node ( elt -- str ) [ [ pprint ] string-out , ] V{ } make ;
: (print-heap) ( i heap -- vector )
2dup l-oob [ V{ } clone ] [ over left over (print-heap) ] if -rot
2dup r-oob [ V{ } clone ] [ over right over (print-heap) ] if -rot
V{ } clone pick pick nth output-node append
-rot 2drop aggregate3 ;
: print-heap ( heap -- )
dup empty? [ drop ] [ 0 swap (print-heap) [ print ] each ] if ;

35
unmaintained/heap/tests.factor
View File

@ -1,35 +0,0 @@
! Binary Min Heap
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
USING: heap test kernel ;
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
{ t } [ 5 3 [comp] ] unit-test
{ V{ } } [ <heap> ] unit-test
{ V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } [ <heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over add-many ] unit-test
{ V{ "hire" "hose" } } [ V{ "hi" "ho" } V{ "re" "se" } aggregate2 ] unit-test
{ V{ "hire" "hose" " it" } } [ V{ "hi" "ho" } V{ "re" "se" "it" } aggregate2 ] unit-test
{ V{ "tracks" "snacks" "crack " } } [ V{ "track" "snack" "crack" } V{ "s" "s" } aggregate2 ] unit-test
{ V{ " top " "left right" } } [ V{ "left" } V{ "right" } V{ "top" } aggregate3 ] unit-test
{ V{ " top "
" dog "
"left right"
"over on "
" man " } } [ V{ "left" "over" } V{ "right" "on " "man " } V{ "top" "dog" } aggregate3 ] unit-test
{ V{ " -6 "
" -4 2 "
" 1 5 3 2 "
" 4 3 7 6 8 3 4 4"
"6 5 5 " } } [ 0 <heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over add-many (print-heap) ] unit-test
{ V{ 5 6 6 7 8 } } [ <heap> { 3 5 4 6 5 7 6 8 } over add-many dup bump dup bump dup bump ] unit-test