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

core/classes/tuple/tuple-tests.factor

@@ -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

core/debugger/debugger-docs.factor

@@ -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

core/debugger/debugger.factor

@@ -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-and-restarts ] recover ;
-        print-error
-        restarts.
-        nl
-        "Type :help for debugging help." print flush
-    ] 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-in-thread. ( thread -- )
-    error-thread get-global
     "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 ;
 

core/listener/listener.factor

@@ -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* ]

core/threads/threads-tests.factor

@@ -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

core/threads/threads.factor

@@ -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
+        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 ;
 
 PRIVATE>
 
 : stop ( -- )
-    self dup exit-handler>> call
+    self [ exit-handler>> call ] [ unregister-thread ] bi next ;
-    unregister-thread next ;
 
 : 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
 
 : yield ( -- ) [ resume ] f suspend drop ;
@@ -166,16 +186,7 @@ M: real sleep
     ] when drop ;
 
 : (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 )
     <thread> [ (spawn) ] keep ;
@@ -184,8 +195,8 @@ M: real sleep
     >r [ [ ] [ ] while ] curry r> spawn ;
 
 : 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 ;
 
 GENERIC: error-in-thread ( error thread -- )

extra/concurrency/combinators/combinators-docs.factor

@@ -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"

extra/concurrency/combinators/combinators-tests.factor

@@ -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

extra/concurrency/combinators/combinators.factor

@@ -4,14 +4,27 @@ USING: concurrency.futures concurrency.count-downs sequences
 kernel ;
 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 -- )
-    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 )
     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 ;

extra/concurrency/count-downs/count-downs.factor

@@ -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? [
+    dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
-        t swap count-down-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? [
+    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 -- )
-    >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
+    swap promise>> mailbox>> spawn-linked-to drop ;
-    promise-mailbox spawn-linked-to drop ;

extra/concurrency/mailboxes/mailboxes.factor

@@ -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 ;

extra/interval-maps/interval-maps-tests.factor

@@ -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

extra/interval-maps/interval-maps.factor

@@ -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
+    all-intervals { } assoc-like
-    [ [ first to>> ] compare ] sort
+    [ [ 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 ;

extra/io/launcher/launcher.factor

@@ -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
+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
 
 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
+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 )
     [

extra/io/pipes/pipes.factor

@@ -23,34 +23,31 @@ HOOK: (pipe) io-backend ( -- pipe )
         r> <encoder-duplex>
     ] 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 ;
 
-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 )
-    [ 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 ;

extra/io/unix/launcher/launcher-tests.factor

@@ -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 [

extra/io/unix/macosx/macosx.factor

@@ -13,9 +13,11 @@ TUPLE: macosx-monitor < monitor handle ;
     ] curry each ;
 
 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
     handle>> dispose ;

extra/io/unix/pipes/pipes-tests.factor

@@ -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"

extra/lcs/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

extra/lcs/lcs-docs.factor

@@ -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"

extra/lcs/lcs-tests.factor

@@ -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

extra/lcs/lcs.factor

@@ -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 ;

extra/lcs/summary.txt

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

extra/lcs/tags.txt

@@ -0,0 +1 @@
+algorithms

extra/levenshtein/authors.txt

@@ -1 +0,0 @@
-Slava Pestov

extra/levenshtein/levenshtein-tests.factor

@@ -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

extra/levenshtein/levenshtein.factor

@@ -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 ;

extra/levenshtein/summary.txt

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

extra/tools/deploy/shaker/shaker.factor

@@ -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

extra/ui/tools/interactor/interactor-tests.factor

@@ -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

extra/ui/tools/interactor/interactor.factor

@@ -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
+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
 
-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>> value>> ;
-    thread-continuation box-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 -- )
+: <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 )
     <source-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*
-    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 )
     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 )
-    [
+    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
     [ 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 }

extra/ui/tools/listener/listener-tests.factor

@@ -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

extra/ui/tools/listener/listener.factor

@@ -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
+    get-workspace listener>> input>> set-editor-string ;
-    workspace-listener
-    listener-gadget-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>> input>> [ set-editor-string ] keep
-    listener-gadget-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-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 -- )
-    [ 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
+        [ com-end ]
-    wait-for-listener ;
+        [ 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*
+    [ delegate graft* ] [ restart-listener ] bi ;
-    dup listener-gadget-input interactor-thread ?box 2drop
-    restart-listener ;
 
 M: listener-gadget ungraft*
-    dup com-end
+    [ com-end ] [ delegate ungraft* ] bi ;
-    delegate ungraft* ;

extra/unicode/script/script.factor

@@ -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: script-table
-VALUE: num>name-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 -- )
+: 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 )
     [
@@ -41,9 +33,9 @@ VALUE: num>name-table
     ] with-compilation-unit ;
 
 : 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 ( -- )
     "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* ;