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

db4
Doug Coleman 2008-05-07 01:09:21 -05:00
commit 5114cdb03f
34 changed files with 490 additions and 269 deletions

View File

@ -542,3 +542,15 @@ TUPLE: another-forget-accessors-test ;
! Missing error check ! Missing error check
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail [ "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

View File

@ -81,13 +81,9 @@ HELP: print-error
HELP: restarts. HELP: restarts.
{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ; { $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 HELP: try
{ $values { "quot" "a quotation" } } { $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 { $examples
"The following example prints an error and keeps going:" "The following example prints an error and keeps going:"
{ $code { $code

View File

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

View File

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

View File

@ -1,5 +1,6 @@
USING: namespaces io tools.test threads kernel USING: namespaces io tools.test threads kernel
concurrency.combinators math ; concurrency.combinators concurrency.promises locals math
words ;
IN: threads.tests IN: threads.tests
3 "x" set 3 "x" set
@ -27,3 +28,16 @@ yield
"i" tget "i" tget
] parallel-map ] parallel-map
] unit-test ] 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

View File

@ -91,6 +91,8 @@ PRIVATE>
[ sleep-queue heap-peek nip millis [-] ] [ sleep-queue heap-peek nip millis [-] ]
} cond ; } cond ;
DEFER: stop
<PRIVATE <PRIVATE
: schedule-sleep ( thread dt -- ) : schedule-sleep ( thread dt -- )
@ -111,36 +113,54 @@ PRIVATE>
[ ] while [ ] while
drop ; 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 ( -- * ) : next ( -- * )
expire-sleep-loop expire-sleep-loop
run-queue dup dlist-empty? [ run-queue dup dlist-empty? [
! We should never be in a state where the only threads drop no-runnable-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
] [ ] [
pop-back pop-back dup array? [ first2 ] [ f swap ] if (next)
dup array? [ first2 ] [ f swap ] if dup set-self
f >>state
continuation>> box>
continue-with
] if ; ] if ;
PRIVATE> PRIVATE>
: stop ( -- ) : stop ( -- )
self dup exit-handler>> call self [ exit-handler>> call ] [ unregister-thread ] bi next ;
unregister-thread next ;
: suspend ( quot state -- obj ) : suspend ( quot state -- obj )
[ [
self continuation>> >box >r
self (>>state) >r self swap call
self swap call next r> self (>>state)
r> self continuation>> >box
next
] callcc1 2nip ; inline ] callcc1 2nip ; inline
: yield ( -- ) [ resume ] f suspend drop ; : yield ( -- ) [ resume ] f suspend drop ;
@ -166,16 +186,7 @@ M: real sleep
] when drop ; ] when drop ;
: (spawn) ( thread -- ) : (spawn) ( thread -- )
[ [ register-thread ] [ namestack swap resume-with ] bi ;
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 ;
: spawn ( quot name -- thread ) : spawn ( quot name -- thread )
<thread> [ (spawn) ] keep ; <thread> [ (spawn) ] keep ;
@ -184,8 +195,8 @@ M: real sleep
>r [ [ ] [ ] while ] curry r> spawn ; >r [ [ ] [ ] while ] curry r> spawn ;
: in-thread ( quot -- ) : in-thread ( quot -- )
>r datastack namestack r> >r datastack r>
[ >r set-namestack set-datastack r> call ] 3curry [ >r set-datastack r> call ] 2curry
"Thread" spawn drop ; "Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- ) GENERIC: error-in-thread ( error thread -- )

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." } { $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." } ; { $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 HELP: parallel-each
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } { $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." } { $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." } ; { $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 HELP: parallel-filter
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } } { $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." } { $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" ARTICLE: "concurrency.combinators" "Concurrent combinators"
"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":" "The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"
{ $subsection parallel-each } { $subsection parallel-each }
{ $subsection 2parallel-each }
{ $subsection parallel-map } { $subsection parallel-map }
{ $subsection 2parallel-map }
{ $subsection parallel-filter } ; { $subsection parallel-filter } ;
ABOUT: "concurrency.combinators" ABOUT: "concurrency.combinators"

View File

@ -1,9 +1,11 @@
IN: concurrency.combinators.tests IN: concurrency.combinators.tests
USING: concurrency.combinators tools.test random kernel math USING: concurrency.combinators tools.test random kernel math
concurrency.mailboxes threads sequences accessors ; concurrency.mailboxes threads sequences accessors arrays ;
[ [ drop ] parallel-each ] must-infer [ [ drop ] parallel-each ] must-infer
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
[ [ ] parallel-map ] must-infer [ [ ] parallel-map ] must-infer
{ 2 1 } [ [ 2array ] 2parallel-map ] must-infer-as
[ [ ] parallel-filter ] must-infer [ [ ] parallel-filter ] must-infer
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test [ { 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 10 over [ push ] curry parallel-each
length length
] unit-test ] 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

View File

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

View File

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

View File

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

View File

@ -11,3 +11,8 @@ SYMBOL: test
[ 2 ] [ 1 test get interval-at ] unit-test [ 2 ] [ 1 test get interval-at ] unit-test
[ f ] [ 2 test get interval-at ] unit-test [ f ] [ 2 test get interval-at ] unit-test
[ f ] [ 0 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

View File

@ -1,5 +1,5 @@
USING: kernel sequences arrays math.intervals accessors USING: kernel sequences arrays math.intervals accessors
math.order sorting math assocs ; math.order sorting math assocs locals namespaces ;
IN: interval-maps IN: interval-maps
TUPLE: interval-map array ; TUPLE: interval-map array ;
@ -24,6 +24,8 @@ M: interval >interval ;
: ensure-disjoint ( intervals -- intervals ) : ensure-disjoint ( intervals -- intervals )
dup keys [ interval-intersect not ] monotonic? dup keys [ interval-intersect not ] monotonic?
[ "Intervals are not disjoint" throw ] unless ; [ "Intervals are not disjoint" throw ] unless ;
PRIVATE> PRIVATE>
: interval-at* ( key map -- value ? ) : interval-at* ( key map -- value ? )
@ -35,7 +37,20 @@ PRIVATE>
: interval-key? ( key map -- ? ) interval-at* nip ; : interval-key? ( key map -- ? ) interval-at* nip ;
: <interval-map> ( specification -- map ) : <interval-map> ( specification -- map )
all-intervals ensure-disjoint all-intervals { } assoc-like
[ [ first to>> ] compare ] sort [ [ first to>> ] compare ] sort ensure-disjoint
[ interval-node boa ] { } assoc>map [ interval-node boa ] { } assoc>map
interval-map boa ; 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 ;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -1 +0,0 @@
Slava Pestov

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

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 ;

View File

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

View File

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

View File

@ -1,11 +1,11 @@
IN: ui.tools.interactor.tests IN: ui.tools.interactor.tests
USING: ui.tools.interactor ui.gadgets.panes namespaces USING: ui.tools.interactor ui.gadgets.panes namespaces
ui.gadgets.editors concurrency.promises threads listener 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 [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] 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 [ ] [ <promise> "promise" set ] unit-test
[ [
self "interactor" get (>>thread)
"interactor" get stream-read-quot "promise" get fulfill "interactor" get stream-read-quot "promise" get fulfill
] "Interactor test" spawn drop ] "Interactor test" spawn drop
@ -27,3 +28,14 @@ tools.test kernel calendar parser ;
[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
] with-interactive-vocabs ] 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

View File

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

View File

@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private ui.gadgets.panes vocabs words tools.test.ui slots.private
threads arrays generic ; threads arrays generic threads accessors listener ;
IN: ui.tools.listener.tests IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test [ f ] [ "word" source-editor command-map empty? ] unit-test
@ -15,7 +15,7 @@ IN: ui.tools.listener.tests
[ "dup" ] [ [ "dup" ] [
\ dup word-completion-string \ dup word-completion-string
] unit-test ] unit-test
[ "equal?" ] [ "equal?" ]
[ \ array \ equal? method word-completion-string ] unit-test [ \ 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 "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
] unit-test ] unit-test
[ t ] [ [ t ] [
"i" get gadget-model doc-end "i" get gadget-model doc-end
"i" get editor-caret* = "i" get editor-caret* =
] unit-test ] 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 ] with-grafted-gadget

View File

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

View File

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