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

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

db4
Doug Coleman 2008-05-07 01:09:21 -05:00
parent ebae774b8c 918418e9e6
commit 5114cdb03f
34 changed files with 490 additions and 269 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
core/classes/tuple/tuple-tests.factor
View File

@ -542,3 +542,15 @@ TUPLE: another-forget-accessors-test ;
! Missing error check
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
TUPLE: subclass-forget-test ;
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
TUPLE: subclass-forget-test-2 < subclass-forget-test ;
TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail

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

@ -81,13 +81,9 @@ HELP: print-error
HELP: restarts.
{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
HELP: error-hook
{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
HELP: try
{ $values { "quot" "a quotation" } }
{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
{ $description "Attempts to call a quotation; if it throws an error, the error is printed to " { $link output-stream } ", stacks are restored, and execution continues after the call to " { $link try } "." }
{ $examples
"The following example prints an error and keeps going:"
{ $code

18
core/debugger/debugger.factor
View File

@ -64,13 +64,14 @@ M: string error. print ;
[ global [ "Error in print-error!" print drop ] bind ]
recover ;
: print-error-and-restarts ( error -- )
print-error
restarts.
nl
"Type :help for debugging help." print flush ;
: try ( quot -- )
[
print-error
restarts.
nl
"Type :help for debugging help." print flush
] recover ;
[ print-error-and-restarts ] recover ;
ERROR: assert got expect ;
@ -269,8 +270,7 @@ M: double-free summary
M: realloc-error summary
drop "Memory reallocation failed" ;
: error-in-thread. ( -- )
error-thread get-global
: error-in-thread. ( thread -- )
"Error in thread " write
[
dup thread-id #
@ -284,7 +284,7 @@ M: thread error-in-thread ( error thread -- )
die drop
] [
global [
error-in-thread. print-error flush
error-thread get-global error-in-thread. print-error flush
] bind
] if ;

2
core/listener/listener.factor
View File

@ -45,6 +45,8 @@ M: object stream-read-quot
SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global
: listen ( -- )
listener-hook get call prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]

16
core/threads/threads-tests.factor
View File

@ -1,5 +1,6 @@
USING: namespaces io tools.test threads kernel
concurrency.combinators math ;
concurrency.combinators concurrency.promises locals math
words ;
IN: threads.tests
3 "x" set
@ -27,3 +28,16 @@ yield
"i" tget
] parallel-map
] unit-test
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
:: spawn-namespace-test ( -- )
[let | p [ <promise> ] g [ gensym ] |
[
g "x" set
[ "x" get p fulfill ] "B" spawn drop
] with-scope
p ?promise g eq?
] ;
[ t ] [ spawn-namespace-test ] unit-test

71
core/threads/threads.factor
View File

@ -91,6 +91,8 @@ PRIVATE>
[ sleep-queue heap-peek nip millis [-] ]
} cond ;
DEFER: stop
<PRIVATE
: schedule-sleep ( thread dt -- )
@ -111,36 +113,54 @@ PRIVATE>
[ ] while
drop ;
: start ( namestack thread -- )
[
set-self
set-namestack
V{ } set-catchstack
{ } set-retainstack
{ } set-datastack
self quot>> [ call stop ] call-clear
] 2 (throw) ;
DEFER: next
: no-runnable-threads ( -- * )
! We should never be in a state where the only threads
! are sleeping; the I/O wait thread is always runnable.
! However, if it dies, we handle this case
! semi-gracefully.
!
! And if sleep-time outputs f, there are no sleeping
! threads either... so WTF.
sleep-time [ die 0 ] unless* (sleep) next ;
: (next) ( arg thread -- * )
f >>state
dup set-self
dup continuation>> ?box
[ nip continue-with ] [ drop start ] if ;
: next ( -- * )
expire-sleep-loop
run-queue dup dlist-empty? [
! We should never be in a state where the only threads
! are sleeping; the I/O wait thread is always runnable.
! However, if it dies, we handle this case
! semi-gracefully.
!
! And if sleep-time outputs f, there are no sleeping
! threads either... so WTF.
drop sleep-time [ die 0 ] unless* (sleep) next
drop no-runnable-threads
] [
pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f >>state
continuation>> box>
continue-with
pop-back dup array? [ first2 ] [ f swap ] if (next)
] if ;
PRIVATE>
: stop ( -- )
self dup exit-handler>> call
unregister-thread next ;
self [ exit-handler>> call ] [ unregister-thread ] bi next ;
: suspend ( quot state -- obj )
[
self continuation>> >box
self (>>state)
self swap call next
>r
>r self swap call
r> self (>>state)
r> self continuation>> >box
next
] callcc1 2nip ; inline
: yield ( -- ) [ resume ] f suspend drop ;
@ -166,16 +186,7 @@ M: real sleep
] when drop ;
: (spawn) ( thread -- )
[
resume-now [
dup set-self
dup register-thread
V{ } set-catchstack
{ } set-retainstack
>r { } set-datastack r>
quot>> [ call stop ] call-clear
] 1 (throw)
] "spawn" suspend 2drop ;
[ register-thread ] [ namestack swap resume-with ] bi ;
: spawn ( quot name -- thread )
<thread> [ (spawn) ] keep ;
@ -184,8 +195,8 @@ M: real sleep
>r [ [ ] [ ] while ] curry r> spawn ;
: in-thread ( quot -- )
>r datastack namestack r>
[ >r set-namestack set-datastack r> call ] 3curry
>r datastack r>
[ >r set-datastack r> call ] 2curry
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )

12
extra/concurrency/combinators/combinators-docs.factor
View File

@ -6,11 +6,21 @@ HELP: parallel-map
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-each
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-filter
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }
@ -19,7 +29,9 @@ HELP: parallel-filter
ARTICLE: "concurrency.combinators" "Concurrent combinators"
"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"
{ $subsection parallel-each }
{ $subsection 2parallel-each }
{ $subsection parallel-map }
{ $subsection 2parallel-map }
{ $subsection parallel-filter } ;
ABOUT: "concurrency.combinators"

25
extra/concurrency/combinators/combinators-tests.factor
View File

@ -1,9 +1,11 @@
IN: concurrency.combinators.tests
USING: concurrency.combinators tools.test random kernel math
concurrency.mailboxes threads sequences accessors ;
concurrency.mailboxes threads sequences accessors arrays ;
[ [ drop ] parallel-each ] must-infer
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
[ [ ] parallel-map ] must-infer
{ 2 1 } [ [ 2array ] 2parallel-map ] must-infer-as
[ [ ] parallel-filter ] must-infer
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test
@ -22,3 +24,24 @@ concurrency.mailboxes threads sequences accessors ;
10 over [ push ] curry parallel-each
length
] unit-test
[ { 10 20 30 } ] [
{ 1 4 3 } { 10 5 10 } [ * ] 2parallel-map
] unit-test
[ { -9 -1 -7 } ] [
{ 1 4 3 } { 10 5 10 } [ - ] 2parallel-map
] unit-test
[
{ 1 4 3 } { 1 0 1 } [ / drop ] 2parallel-each
] must-fail
[ 20 ]
[
V{ } clone
10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each
length
] unit-test
[ { f } [ "OOPS" throw ] parallel-each ] must-fail

25
extra/concurrency/combinators/combinators.factor
View File

@ -4,14 +4,27 @@ USING: concurrency.futures concurrency.count-downs sequences
kernel ;
IN: concurrency.combinators
: parallel-map ( seq quot -- newseq )
[ curry future ] curry map dup [ ?future ] change-each ;
inline
: (parallel-each) ( n quot -- )
>r <count-down> r> keep await ; inline
: parallel-each ( seq quot -- )
over length <count-down>
[ [ >r curry r> spawn-stage ] 2curry each ] keep await ;
inline
over length [
[ >r curry r> spawn-stage ] 2curry each
] (parallel-each) ; inline
: 2parallel-each ( seq1 seq2 quot -- )
2over min-length [
[ >r 2curry r> spawn-stage ] 2curry 2each
] (parallel-each) ; inline
: parallel-filter ( seq quot -- newseq )
over >r pusher >r each r> r> like ; inline
: future-values dup [ ?future ] change-each ; inline
: parallel-map ( seq quot -- newseq )
[ curry future ] curry map future-values ;
inline
: 2parallel-map ( seq1 seq2 quot -- newseq )
[ 2curry future ] curry 2map future-values ;

20
extra/concurrency/count-downs/count-downs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel math concurrency.promises
concurrency.mailboxes ;
concurrency.mailboxes debugger accessors ;
IN: concurrency.count-downs
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
@ -9,9 +9,7 @@ IN: concurrency.count-downs
TUPLE: count-down n promise ;
: count-down-check ( count-down -- )
dup count-down-n zero? [
t swap count-down-promise fulfill
] [ drop ] if ;
dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
: <count-down> ( n -- count-down )
dup 0 < [ "Invalid count for count down" throw ] when
@ -19,15 +17,12 @@ TUPLE: count-down n promise ;
dup count-down-check ;
: count-down ( count-down -- )
dup count-down-n dup zero? [
"Count down already done" throw
] [
1- over set-count-down-n
count-down-check
] if ;
dup n>> dup zero?
[ "Count down already done" throw ]
[ 1- >>n count-down-check ] if ;
: await-timeout ( count-down timeout -- )
>r count-down-promise r> ?promise-timeout drop ;
>r promise>> r> ?promise-timeout ?linked t assert= ;
: await ( count-down -- )
f await-timeout ;
@ -35,5 +30,4 @@ TUPLE: count-down n promise ;
: spawn-stage ( quot count-down -- )
[ [ count-down ] curry compose ] keep
"Count down stage"
swap count-down-promise
promise-mailbox spawn-linked-to drop ;
swap promise>> mailbox>> spawn-linked-to drop ;

5
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -3,7 +3,7 @@
IN: concurrency.mailboxes
USING: dlists threads sequences continuations
namespaces random math quotations words kernel arrays assocs
init system concurrency.conditions accessors ;
init system concurrency.conditions accessors debugger ;
TUPLE: mailbox threads data closed ;
@ -83,6 +83,9 @@ M: mailbox dispose
TUPLE: linked-error error thread ;
M: linked-error error.
[ thread>> error-in-thread. ] [ error>> error. ] bi ;
C: <linked-error> linked-error
: ?linked dup linked-error? [ rethrow ] when ;

5
extra/interval-maps/interval-maps-tests.factor
View File

@ -11,3 +11,8 @@ SYMBOL: test
[ 2 ] [ 1 test get interval-at ] unit-test
[ f ] [ 2 test get interval-at ] unit-test
[ f ] [ 0 test get interval-at ] unit-test
[ { { { 1 4 } 3 } { { 4 8 } 6 } } <interval-map> ] must-fail
[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]
[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test

21
extra/interval-maps/interval-maps.factor
View File

@ -1,5 +1,5 @@
USING: kernel sequences arrays math.intervals accessors
math.order sorting math assocs ;
math.order sorting math assocs locals namespaces ;
IN: interval-maps
TUPLE: interval-map array ;
@ -24,6 +24,8 @@ M: interval >interval ;
: ensure-disjoint ( intervals -- intervals )
dup keys [ interval-intersect not ] monotonic?
[ "Intervals are not disjoint" throw ] unless ;
PRIVATE>
: interval-at* ( key map -- value ? )
@ -35,7 +37,20 @@ PRIVATE>
: interval-key? ( key map -- ? ) interval-at* nip ;
: <interval-map> ( specification -- map )
all-intervals ensure-disjoint
[ [ first to>> ] compare ] sort
all-intervals { } assoc-like
[ [ first to>> ] compare ] sort ensure-disjoint
[ interval-node boa ] { } assoc>map
interval-map boa ;
:: coalesce ( alist -- specification )
! Only works with integer keys, because they're discrete
! Makes 2array keys
[
alist sort-keys unclip first2 dupd roll
[| oldkey oldval key val | ! Underneath is start
oldkey 1+ key =
oldval val = and
[ oldkey 2array oldval 2array , key ] unless
key val
] assoc-each [ 2array ] bi@ ,
] { } make ;

24
extra/io/launcher/launcher.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.backend io.timeouts io.pipes system kernel
namespaces strings hashtables sequences assocs combinators
vocabs.loader init threads continuations math io.encodings
io.streams.duplex io.nonblocking io.streams.duplex accessors
concurrency.flags destructors ;
USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
io.streams.duplex io.nonblocking ;
IN: io.launcher
TUPLE: process < identity-tuple
@ -149,15 +149,11 @@ M: process set-timeout set-process-timeout ;
M: process timed-out kill-process ;
M: object pipeline-element-quot
[
>process
swap >>stdout
swap >>stdin
run-detached
] curry ;
M: process wait-for-pipeline-element wait-for-process ;
M: object run-pipeline-element
[ >process swap >>stdout swap >>stdin run-detached ]
[ drop [ [ close-handle ] when* ] bi@ ]
3bi
wait-for-process ;
: <process-reader*> ( process encoding -- process stream )
[

43
extra/io/pipes/pipes.factor
View File

@ -23,34 +23,31 @@ HOOK: (pipe) io-backend ( -- pipe )
r> <encoder-duplex>
] with-destructors ;
: with-fds ( input-fd output-fd quot -- )
>r >r [ <reader> dup add-always-destructor ] [ input-stream get ] if* r> r> [
>r [ <writer> dup add-always-destructor ] [ output-stream get ] if* r>
with-output-stream*
] 2curry with-input-stream* ; inline
<PRIVATE
: <pipes> ( n -- pipes )
[ (pipe) dup add-always-destructor ] replicate
f f pipe boa [ prefix ] [ suffix ] bi
2 <clumps> ;
: ?reader [ <reader> dup add-always-destructor ] [ input-stream get ] if* ;
: ?writer [ <writer> dup add-always-destructor ] [ output-stream get ] if* ;
: with-pipe-fds ( seq -- results )
GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
M: callable run-pipeline-element
[
[ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
[ >r [ first in>> ] [ second out>> ] bi r> 2curry ] 2map
[ call ] parallel-map
>r [ ?reader ] [ ?writer ] bi*
r> with-streams*
] with-destructors ;
GENERIC: pipeline-element-quot ( obj -- quot )
: <pipes> ( n -- pipes )
[
[ (pipe) dup add-error-destructor ] replicate
T{ pipe } [ prefix ] [ suffix ] bi
2 <clumps>
] with-destructors ;
M: callable pipeline-element-quot
[ with-fds ] curry ;
GENERIC: wait-for-pipeline-element ( obj -- result )
M: object wait-for-pipeline-element ;
PRIVATE>
: run-pipeline ( seq -- results )
[ pipeline-element-quot ] map
with-pipe-fds
[ wait-for-pipeline-element ] map ;
[ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
[
>r [ first in>> ] [ second out>> ] bi
r> run-pipeline-element
] 2parallel-map ;

2
extra/io/unix/launcher/launcher-tests.factor
View File

@ -99,7 +99,7 @@ accessors kernel sequences io.encodings.utf8 ;
utf8 file-contents
] unit-test
[ ] [ "append-test" temp-file delete-file ] unit-test
[ "append-test" temp-file delete-file ] ignore-errors
[ "hi\nhi\n" ] [
2 [

8
extra/io/unix/macosx/macosx.factor
View File

@ -13,9 +13,11 @@ TUPLE: macosx-monitor < monitor handle ;
] curry each ;
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
path mailbox macosx-monitor new-monitor
dup [ enqueue-notifications ] curry
path 1array 0 0 <event-stream> >>handle ;
[let | path [ path normalize-path ] |
path mailbox macosx-monitor new-monitor
dup [ enqueue-notifications ] curry
path 1array 0 0 <event-stream> >>handle
] ;
M: macosx-monitor dispose
handle>> dispose ;

1
extra/io/unix/pipes/pipes-tests.factor
View File

@ -9,6 +9,7 @@ IN: io.unix.pipes.tests
"ls"
[
input-stream [ utf8 <decoder> ] change
output-stream [ utf8 <encoder> ] change
input-stream get lines reverse [ print ] each f
]
"grep x"

1
extra/lcs/authors.txt Executable file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

35
extra/lcs/lcs-docs.factor Executable file
View File

@ -0,0 +1,35 @@
USING: help.syntax help.markup ;
IN: lcs
HELP: levenshtein
{ $values { "old" "a sequence" } { "new" "a sequence" } { "n" "the Levenshtein distance" } }
{ $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ;
HELP: lcs
{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "lcs" "a longest common subsequence" } }
{ $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ;
HELP: diff
{ $values { "old" "a sequence" } { "new" "a sequence" } { "diff" "an edit script" } }
{ $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ;
HELP: retain
{ $class-description "Represents an action in an edit script where an item is kept, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is retained" } ;
HELP: delete
{ $class-description "Represents an action in an edit script where an item is deleted, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is deleted" } ;
HELP: insert
{ $class-description "Represents an action in an edit script where an item is added, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is inserted" } ;
ARTICLE: "lcs" "LCS, Diffing and Distance"
"This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences."
{ $subsection lcs }
{ $subsection diff }
{ $subsection levenshtein }
"The " { $link diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot."
{ $subsection insert }
{ $subsection delete }
{ $subsection retain } ;
ABOUT: "lcs"

25
extra/lcs/lcs-tests.factor Executable file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ;
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
[ "hell" ] [ "hello" "hell" lcs ] unit-test
[ "hell" ] [ "hell" "hello" lcs ] unit-test
[ "ell" ] [ "ell" "hell" lcs ] unit-test
[ "ell" ] [ "hell" "ell" lcs ] unit-test
[ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
[ {
T{ delete f CHAR: f }
T{ retain f CHAR: a }
T{ delete f CHAR: x }
T{ retain f CHAR: b }
T{ delete f CHAR: c }
T{ retain f CHAR: d }
T{ insert f CHAR: e }
T{ insert f CHAR: f }
} ] [ "faxbcd" "abdef" diff ] unit-test

97
extra/lcs/lcs.factor Executable file
View File

@ -0,0 +1,97 @@
USING: sequences kernel math locals math.order math.ranges
accessors combinators.lib arrays namespaces combinators ;
IN: lcs
<PRIVATE
: levenshtein-step ( insert delete change same? -- next )
0 1 ? + >r [ 1+ ] bi@ r> min min ;
: lcs-step ( insert delete change same? -- next )
1 -9999 ? + max max ; ! Replace -9999 with -inf when added
:: loop-step ( i j matrix old new step -- )
i j 1+ matrix nth nth ! insertion
i 1+ j matrix nth nth ! deletion
i j matrix nth nth ! replace/retain
i old nth j new nth = ! same?
step call
i 1+ j 1+ matrix nth set-nth ; inline
: lcs-initialize ( |str1| |str2| -- matrix )
[ drop 0 <array> ] with map ;
: levenshtein-initialize ( |str1| |str2| -- matrix )
[ [ + ] curry map ] with map ;
:: run-lcs ( old new init step -- matrix )
[let | matrix [ old length 1+ new length 1+ init call ] |
old length [0,b) [| i |
new length [0,b)
[| j | i j matrix old new step loop-step ]
each
] each matrix ] ; inline
PRIVATE>
: levenshtein ( old new -- n )
[ levenshtein-initialize ] [ levenshtein-step ]
run-lcs peek peek ;
TUPLE: retain item ;
TUPLE: delete item ;
TUPLE: insert item ;
<PRIVATE
TUPLE: trace-state old new table i j ;
: old-nth ( state -- elt )
[ i>> 1- ] [ old>> ] bi nth ;
: new-nth ( state -- elt )
[ j>> 1- ] [ new>> ] bi nth ;
: top-beats-side? ( state -- ? )
[ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ]
[ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ;
: retained? ( state -- ? )
{
[ i>> 0 > ] [ j>> 0 > ]
[ [ old-nth ] [ new-nth ] bi = ]
} <-&& ;
: do-retain ( state -- state )
dup old-nth retain boa ,
[ 1- ] change-i [ 1- ] change-j ;
: inserted? ( state -- ? )
[ j>> 0 > ]
[ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;
: do-insert ( state -- state )
dup new-nth insert boa , [ 1- ] change-j ;
: deleted? ( state -- ? )
[ i>> 0 > ]
[ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;
: do-delete ( state -- state )
dup old-nth delete boa , [ 1- ] change-i ;
: (trace-diff) ( state -- )
{
{ [ dup retained? ] [ do-retain (trace-diff) ] }
{ [ dup inserted? ] [ do-insert (trace-diff) ] }
{ [ dup deleted? ] [ do-delete (trace-diff) ] }
[ drop ] ! i=j=0
} cond ;
: trace-diff ( old new table -- diff )
[ ] [ first length 1- ] [ length 1- ] tri trace-state boa
[ (trace-diff) ] { } make reverse ;
PRIVATE>
: diff ( old new -- diff )
2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;
: lcs ( seq1 seq2 -- lcs )
[ diff [ retain? ] filter ] keep [ item>> ] swap map-as ;

1
extra/lcs/summary.txt Executable file
View File

@ -0,0 +1 @@
Levenshtein distance and diff between sequences

1
extra/lcs/tags.txt Executable file
View File

@ -0,0 +1 @@
algorithms

1
extra/levenshtein/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

9
extra/levenshtein/levenshtein-tests.factor
View File

@ -1,9 +0,0 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: levenshtein.tests
USING: tools.test levenshtein ;
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test

47
extra/levenshtein/levenshtein.factor
View File

@ -1,47 +0,0 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help io kernel math namespaces sequences
math.order ;
IN: levenshtein
: <matrix> ( m n -- matrix )
[ drop 0 <array> ] with map ; inline
: matrix-> nth nth ; inline
: ->matrix nth set-nth ; inline
SYMBOL: d
: ->d ( n i j -- ) d get ->matrix ; inline
: d-> ( i j -- n ) d get matrix-> ; inline
SYMBOL: costs
: init-d ( str1 str2 -- )
[ length 1+ ] bi@ 2dup <matrix> d set
[ 0 over ->d ] each
[ dup 0 ->d ] each ; inline
: compute-costs ( str1 str2 -- )
swap [
[ = 0 1 ? ] with { } map-as
] curry { } map-as costs set ; inline
: levenshtein-step ( i j -- )
[ 1+ d-> 1+ ] 2keep
[ >r 1+ r> d-> 1+ ] 2keep
[ d-> ] 2keep
[ costs get matrix-> + min min ] 2keep
>r 1+ r> 1+ ->d ; inline
: levenshtein-result ( -- n ) d get peek peek ; inline
: levenshtein ( str1 str2 -- n )
[
2dup init-d
2dup compute-costs
[ length ] bi@ [
[ levenshtein-step ] curry each
] with each
levenshtein-result
] with-scope ;

1
extra/levenshtein/summary.txt
View File

@ -1 +0,0 @@
Levenshtein edit distance algorithm

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

@ -114,7 +114,7 @@ IN: tools.deploy.shaker
continuations:error-continuation
continuations:error-thread
continuations:restarts
error-hook
listener:error-hook
init:init-hooks
inspector:inspector-hook
io.thread:io-thread

18
extra/ui/tools/interactor/interactor-tests.factor
View File

@ -1,11 +1,11 @@
IN: ui.tools.interactor.tests
USING: ui.tools.interactor ui.gadgets.panes namespaces
ui.gadgets.editors concurrency.promises threads listener
tools.test kernel calendar parser ;
tools.test kernel calendar parser accessors ;
\ <interactor> must-infer
[
\ <interactor> must-infer
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
@ -13,6 +13,7 @@ tools.test kernel calendar parser ;
[ ] [ <promise> "promise" set ] unit-test
[
self "interactor" get (>>thread)
"interactor" get stream-read-quot "promise" get fulfill
] "Interactor test" spawn drop
@ -27,3 +28,14 @@ tools.test kernel calendar parser ;
[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
] with-interactive-vocabs
! Hang
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
[ ] [ 1000 sleep ] unit-test
[ ] [ "interactor" get interactor-eof ] unit-test

75
extra/ui/tools/interactor/interactor.factor
View File

@ -1,53 +1,53 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math
math.vectors models namespaces parser prettyprint quotations
sequences strings threads listener
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions boxes calendar concurrency.flags ui.tools.workspace
accessors math.order ;
hashtables io io.styles kernel math math.order math.vectors
models namespaces parser prettyprint quotations sequences
strings threads listener classes.tuple ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
ui.gestures definitions calendar concurrency.flags
ui.tools.workspace accessors ;
IN: ui.tools.interactor
TUPLE: interactor history output flag thread help ;
! If waiting is t, we're waiting for user input, and invoking
! evaluate-input resumes the thread.
TUPLE: interactor output history flag thread waiting help ;
: register-self ( interactor -- )
self >>thread drop ;
: interactor-continuation ( interactor -- continuation )
interactor-thread box-value
thread-continuation box-value ;
thread>> continuation>> value>> ;
: interactor-busy? ( interactor -- ? )
interactor-thread box-full? not ;
#! We're busy if there's no thread to resume.
[ waiting>> ]
[ thread>> dup [ thread-registered? ] when ]
bi and not ;
: interactor-use ( interactor -- seq )
dup interactor-busy? [ drop f ] [
use swap
interactor-continuation continuation-name
interactor-continuation name>>
assoc-stack
] if ;
: init-caret-help ( interactor -- )
dup editor-caret 1/3 seconds <delay>
swap set-interactor-help ;
: init-interactor-history ( interactor -- )
V{ } clone swap set-interactor-history ;
: init-interactor-state ( interactor -- )
<flag> over set-interactor-flag
<box> swap set-interactor-thread ;
: <help-model> ( interactor -- model )
editor-caret 1/3 seconds <delay> ;
: <interactor> ( output -- gadget )
<source-editor>
interactor construct-editor
tuck set-interactor-output
dup init-interactor-history
dup init-interactor-state
dup init-caret-help ;
V{ } clone >>history
<flag> >>flag
dup <help-model> >>help
swap >>output ;
M: interactor graft*
dup delegate graft*
dup interactor-help add-connection ;
[ delegate graft* ] [ dup help>> add-connection ] bi ;
M: interactor ungraft*
[ dup help>> remove-connection ] [ delegate ungraft ] bi ;
: word-at-loc ( loc interactor -- word )
over [
@ -58,7 +58,7 @@ M: interactor graft*
] if ;
M: interactor model-changed
2dup interactor-help eq? [
2dup help>> eq? [
swap model-value over word-at-loc swap show-summary
] [
delegate model-changed
@ -69,7 +69,7 @@ M: interactor model-changed
[ H{ { font-style bold } } format ] with-nesting ;
: interactor-input. ( string interactor -- )
interactor-output [
output>> [
dup string? [ dup write-input nl ] [ short. ] if
] with-output-stream* ;
@ -77,7 +77,7 @@ M: interactor model-changed
over empty? [ 2drop ] [ interactor-history push-new ] if ;
: interactor-continue ( obj interactor -- )
interactor-thread box> resume-with ;
thread>> resume-with ;
: clear-input ( interactor -- ) gadget-model clear-doc ;
@ -99,10 +99,12 @@ M: interactor model-changed
] unless drop ;
: interactor-yield ( interactor -- obj )
[
[ interactor-thread >box ] keep
interactor-flag raise-flag
] curry "input" suspend ;
dup thread>> self eq? [
t >>waiting
[ [ flag>> raise-flag ] curry "input" suspend ] keep
f >>waiting
drop
] [ drop f ] if ;
M: interactor stream-readln
[ interactor-yield ] keep interactor-finish
@ -161,7 +163,8 @@ M: interactor stream-read-quot
} cond ;
M: interactor pref-dim*
0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
[ line-height 4 * 0 swap 2array ] [ delegate pref-dim* ] bi
vmax ;
interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input }

23
extra/ui/tools/listener/listener-tests.factor
View File

@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
threads arrays generic ;
threads arrays generic threads accessors listener ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test
@ -15,7 +15,7 @@ IN: ui.tools.listener.tests
[ "dup" ] [
\ dup word-completion-string
] unit-test
[ "equal?" ]
[ \ array \ equal? method word-completion-string ] unit-test
@ -28,9 +28,26 @@ IN: ui.tools.listener.tests
[ ] [
"i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
] unit-test
[ t ] [
"i" get gadget-model doc-end
"i" get editor-caret* =
] unit-test
! Race condition discovered by SimonRC
[ ] [
[
"listener" get input>>
[ stream-read-quot drop ]
[ stream-read-quot drop ] bi
] "OH, HAI" spawn drop
] unit-test
[ ] [ "listener" get clear-output ] unit-test
[ ] [ "listener" get restart-listener ] unit-test
[ ] [ 1000 sleep ] unit-test
[ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget

61
extra/ui/tools/listener/listener.factor
View File

@ -20,7 +20,7 @@ TUPLE: listener-gadget input output stack ;
[ input>> ] [ output>> <pane-stream> ] bi ;
: <listener-input> ( listener -- gadget )
listener-gadget-output <pane-stream> <interactor> ;
output>> <pane-stream> <interactor> ;
: listener-input, ( -- )
g <listener-input> g-> set-listener-gadget-input
@ -32,31 +32,29 @@ TUPLE: listener-gadget input output stack ;
"cookbook" ($link) "." print nl ;
M: listener-gadget focusable-child*
listener-gadget-input ;
input>> ;
M: listener-gadget call-tool* ( input listener -- )
>r input-string r> listener-gadget-input set-editor-string ;
>r string>> r> input>> set-editor-string ;
M: listener-gadget tool-scroller
listener-gadget-output find-scroller ;
output>> find-scroller ;
: wait-for-listener ( listener -- )
#! Wait for the listener to start.
listener-gadget-input interactor-flag wait-for-flag ;
input>> flag>> wait-for-flag ;
: workspace-busy? ( workspace -- ? )
workspace-listener listener-gadget-input interactor-busy? ;
listener>> input>> interactor-busy? ;
: listener-input ( string -- )
get-workspace
workspace-listener
listener-gadget-input set-editor-string ;
get-workspace listener>> input>> set-editor-string ;
: (call-listener) ( quot listener -- )
listener-gadget-input interactor-call ;
input>> interactor-call ;
: call-listener ( quot -- )
[ workspace-busy? not ] get-workspace* workspace-listener
[ workspace-busy? not ] get-workspace* listener>>
[ dup wait-for-listener (call-listener) ] 2curry
"Listener call" spawn drop ;
@ -68,8 +66,7 @@ M: listener-operation invoke-command ( target command -- )
: eval-listener ( string -- )
get-workspace
workspace-listener
listener-gadget-input [ set-editor-string ] keep
listener>> input>> [ set-editor-string ] keep
evaluate-input ;
: listener-run-files ( seq -- )
@ -80,10 +77,10 @@ M: listener-operation invoke-command ( target command -- )
] if ;
: com-end ( listener -- )
listener-gadget-input interactor-eof ;
input>> interactor-eof ;
: clear-output ( listener -- )
listener-gadget-output pane-clear ;
output>> pane-clear ;
\ clear-output H{ { +listener+ t } } define-command
@ -147,23 +144,26 @@ M: stack-display tool-scroller
: listener-thread ( listener -- )
dup listener-streams [
[
[ [ ui-listener-hook ] curry listener-hook set ]
[ [ ui-error-hook ] curry error-hook set ]
[ [ ui-inspector-hook ] curry inspector-hook set ] tri
welcome.
listener
] with-input-stream*
] with-output-stream* ;
[ [ ui-listener-hook ] curry listener-hook set ]
[ [ ui-error-hook ] curry error-hook set ]
[ [ ui-inspector-hook ] curry inspector-hook set ] tri
welcome.
listener
] with-streams* ;
: start-listener-thread ( listener -- )
[ listener-thread ] curry "Listener" spawn drop ;
[
[ input>> register-self ] [ listener-thread ] bi
] curry "Listener" spawn drop ;
: restart-listener ( listener -- )
#! Returns when listener is ready to receive input.
dup com-end dup clear-output
dup start-listener-thread
wait-for-listener ;
{
[ com-end ]
[ clear-output ]
[ start-listener-thread ]
[ wait-for-listener ]
} cleave ;
: init-listener ( listener -- )
f <model> swap set-listener-gadget-stack ;
@ -189,10 +189,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
[ default-gesture-handler ] [ 3drop f ] if ;
M: listener-gadget graft*
dup delegate graft*
dup listener-gadget-input interactor-thread ?box 2drop
restart-listener ;
[ delegate graft* ] [ restart-listener ] bi ;
M: listener-gadget ungraft*
dup com-end
delegate ungraft* ;
[ com-end ] [ delegate ungraft* ] bi ;

46
extra/unicode/script/script.factor
View File

@ -1,12 +1,12 @@
USING: unicode.syntax.backend kernel sequences assocs io.files
io.encodings ascii math.ranges io splitting math.parser
namespaces byte-arrays locals math sets io.encodings.ascii
words compiler.units ;
words compiler.units arrays interval-maps ;
IN: unicode.script
<PRIVATE
VALUE: char>num-table
VALUE: num>name-table
VALUE: script-table
SYMBOL: interned
: parse-script ( stream -- assoc )
! assoc is code point/range => name
@ -14,26 +14,18 @@ VALUE: num>name-table
";" split1 [ [ blank? ] trim ] bi@
] H{ } map>assoc ;
: set-if ( value var -- )
dup 500000 < [ set ] [ 2drop ] if ;
: range, ( value key -- )
swap interned get
[ word-name = ] with find nip 2array , ;
: expand-ranges ( assoc -- char-assoc )
! char-assoc is code point => name
[ [
CHAR: . pick member? [
swap ".." split1 [ hex> ] bi@ [a,b]
[ set-if ] with each
] [ swap hex> set-if ] if
] assoc-each ] H{ } make-assoc ;
: hash>byte-array ( hash -- byte-array )
[ keys supremum 1+ <byte-array> dup ] keep
[ -rot set-nth ] with assoc-each ;
: make-char>num ( assoc -- char>num-table )
expand-ranges
[ num>name-table index ] assoc-map
hash>byte-array ;
: expand-ranges ( assoc -- interval-map )
[
[
CHAR: . pick member? [
swap ".." split1 [ hex> ] bi@ 2array
] [ swap hex> ] if range,
] assoc-each
] { } make <interval-map> ;
: >symbols ( strings -- symbols )
[
@ -41,9 +33,9 @@ VALUE: num>name-table
] with-compilation-unit ;
: process-script ( ranges -- )
[ values prune \ num>name-table set-value ]
[ make-char>num \ char>num-table set-value ] bi
num>name-table >symbols \ num>name-table set-value ;
dup values prune >symbols interned [
expand-ranges \ script-table set-value
] with-variable ;
: load-script ( -- )
"resource:extra/unicode/script/Scripts.txt"
@ -52,5 +44,7 @@ VALUE: num>name-table
load-script
PRIVATE>
SYMBOL: Unknown
: script-of ( char -- script )
char>num-table nth num>name-table nth ;
script-table interval-at [ Unknown ] unless* ;