diff --git a/core/threads/threads.factor b/core/threads/threads.factor index ee249c70a7..2cb7a3c3d0 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -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 ( -- ) \ run-queue set-global - f sleep-queue set-global + sleep-queue set-global [ idle-thread ] in-thread ; [ init-threads ] "threads" add-init-hook - PRIVATE> diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index b1456178df..fbb60b2d49 100644 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -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 diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 59414a1142..c255e0a78e 100644 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -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 ) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 94bda9e720..b59f758ad8 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -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? ; + +: ( timeout continuation -- obj ) + >r dup [ millis + ] when r> + { + set-thread-timeout + set-thread-continuation + } thread construct ; + : make-mailbox ( -- mailbox ) V{ } clone 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 swap set-mailbox-threads - [ schedule-thread ] each yield ; + [ mailbox-threads ] keep + V{ } clone swap set-mailbox-threads + [ thread-continuation schedule-thread ] each yield ; 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? [ + [ 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 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 ; ; + [ ] random-pid make-mailbox ; : 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 ; + 1quotation random-pid make-mailbox ; PRIVATE> : self ( -- process ) @@ -187,7 +206,7 @@ MATCH-VARS: ?from ?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 swap set-promise-processes - [ schedule-thread ] each yield + V{ } clone swap set-promise-processes + [ thread-continuation schedule-thread ] each yield ] if ; 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 ! ****************************** diff --git a/extra/heaps/heaps-tests.factor b/extra/heaps/heaps-tests.factor new file mode 100644 index 0000000000..a8087916e7 --- /dev/null +++ b/extra/heaps/heaps-tests.factor @@ -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 + +[ pop-heap ] unit-test-fails +[ pop-heap ] unit-test-fails + +[ t ] [ heap-empty? ] unit-test +[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ t ] [ heap-empty? ] unit-test +[ f ] [ 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 } } } ] +[ { 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 } } } ] [ + { 3 5 4 6 5 7 6 8 } over push-heap* + 3 [ dup pop-heap* ] times +] unit-test + +[ 2 ] [ 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 ] [ 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 ] [ 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 diff --git a/extra/heaps/heaps.factor b/extra/heaps/heaps.factor new file mode 100644 index 0000000000..2ff9096483 --- /dev/null +++ b/extra/heaps/heaps.factor @@ -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 + + ( -- obj ) + V{ } clone heap construct-boa ; +PRIVATE> + +TUPLE: min-heap ; + +: ( -- obj ) + min-heap construct-delegate ; + +TUPLE: max-heap ; + +: ( -- obj ) + max-heap construct-delegate ; + +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? ; diff --git a/extra/http/server/responders/callback/callback.factor b/extra/http/server/responders/callback/callback.factor index 12033503c1..6a5e32d32f 100644 --- a/extra/http/server/responders/callback/callback.factor +++ b/extra/http/server/responders/callback/callback.factor @@ -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 ( -- ) #! Return the global table of continuations diff --git a/extra/roman/roman-tests.factor b/extra/roman/roman-tests.factor index aac7d14d90..e850411726 100644 --- a/extra/roman/roman-tests.factor +++ b/extra/roman/roman-tests.factor @@ -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 diff --git a/extra/roman/roman.factor b/extra/roman/roman.factor index 482d52e972..130dfb127d 100644 --- a/extra/roman/roman.factor +++ b/extra/roman/roman.factor @@ -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 r dup unclip add r> - v, [ pick ,, call [ v, ] unless ] curry 2each ,v - ] { } make ; - : roman<= ( ch1 ch2 -- ? ) [ 1string roman-digits index ] 2apply >= ; diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index e457139bcd..470cd096e1 100644 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -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 diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 147af87cc2..d6cf1fe1dc 100644 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -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 = ; + diff --git a/extra/store/store-tests.factor b/extra/store/store-tests.factor new file mode 100644 index 0000000000..97b39bcffd --- /dev/null +++ b/extra/store/store-tests.factor @@ -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 diff --git a/extra/store/store.factor b/extra/store/store.factor index 7d3092a74f..38f078b2a8 100644 --- a/extra/store/store.factor +++ b/extra/store/store.factor @@ -11,12 +11,12 @@ C: store [ store-data ] keep store-path [ [ 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 [ deserialize ] with-stream @@ -30,4 +30,3 @@ C: store ] [ drop >r 2dup set-global r> set-at ] if ; - diff --git a/unmaintained/heap/heap.factor b/unmaintained/heap/heap.factor deleted file mode 100644 index 53c4022a99..0000000000 --- a/unmaintained/heap/heap.factor +++ /dev/null @@ -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 ) 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 ; \ No newline at end of file diff --git a/unmaintained/heap/heap.facts b/unmaintained/heap/heap.facts deleted file mode 100644 index 5dfe472edc..0000000000 --- a/unmaintained/heap/heap.facts +++ /dev/null @@ -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 } -{ $subsection add } -{ $subsection add-many } -{ $subsection bump } -{ $subsection gbump } -{ $subsection print-heap } -; - -HELP: -"Creates a new heap with nothing on it." ; - -HELP: add -"Adds 1 element to the heap." -{ $examples - { $code - "USE: 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" - " { 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" - " { 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" - " { 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" - " { 7 6 5 4 3 2 1 } over add-many" - "print-heap" - } -} -; \ No newline at end of file diff --git a/unmaintained/heap/human tests.factor b/unmaintained/heap/human tests.factor deleted file mode 100644 index aeec5d884d..0000000000 --- a/unmaintained/heap/human tests.factor +++ /dev/null @@ -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 - ; \ No newline at end of file diff --git a/unmaintained/heap/load.factor b/unmaintained/heap/load.factor deleted file mode 100644 index d0d925b1a2..0000000000 --- a/unmaintained/heap/load.factor +++ /dev/null @@ -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" -} } ; \ No newline at end of file diff --git a/unmaintained/heap/print.factor b/unmaintained/heap/print.factor deleted file mode 100644 index e79c246ba2..0000000000 --- a/unmaintained/heap/print.factor +++ /dev/null @@ -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 ; \ No newline at end of file diff --git a/unmaintained/heap/tests.factor b/unmaintained/heap/tests.factor deleted file mode 100644 index a166933c0c..0000000000 --- a/unmaintained/heap/tests.factor +++ /dev/null @@ -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{ } } [ ] unit-test - -{ V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } [ { 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 { 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 } } [ { 3 5 4 6 5 7 6 8 } over add-many dup bump dup bump dup bump ] unit-test \ No newline at end of file