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

2008-07-19 11:04:39 -07:00 · 2008-07-19 11:04:39 -07:00 · b5d2f7f219
parent f30042cc8c 541cff7dca
commit b5d2f7f219
63 changed files with 985 additions and 738 deletions
--- a/core/binary-search/binary-search-docs.factor
+++ b/core/binary-search/binary-search-docs.factor
@ -0,0 +1,43 @@
+IN: binary-search
+USING: help.markup help.syntax sequences kernel math.order ;
+
+ARTICLE: "binary-search" "Binary search"
+"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
+{ $subsection search }
+"Variants of sequence words optimized for sorted sequences:"
+{ $subsection sorted-index }
+{ $subsection sorted-member? }
+{ $subsection sorted-memq? }
+{ $see-also "order-specifiers" "sequences-sorting" } ;
+
+ABOUT: "binary-search"
+
+HELP: search
+{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
+{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
+$nl
+"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."
+$nl
+"If the sequence is empty, outputs " { $link f } " " { $link f } "." }
+{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } ;
+
+{ find find-from find-last find-last find-last-from search } related-words
+
+HELP: sorted-index
+{ $values { "elt" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
+{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
+{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
+
+{ index index-from last-index last-index-from sorted-index } related-words
+
+HELP: sorted-member?
+{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
+{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ;
+
+{ member? sorted-member? } related-words
+
+HELP: sorted-memq?
+{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
+{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
+
+{ memq? sorted-memq? } related-words
--- a/core/binary-search/binary-search-tests.factor
+++ b/core/binary-search/binary-search-tests.factor
@ -0,0 +1,17 @@
+IN: binary-search.tests
+USING: binary-search math.order vectors kernel tools.test ;
+
+\ sorted-member? must-infer
+
+[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
+[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
+[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
+[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
+[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
+[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
+[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
+
+[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
+[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
+[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
--- a/core/binary-search/binary-search.factor
+++ b/core/binary-search/binary-search.factor
@ -0,0 +1,46 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.private accessors math
+math.order combinators ;
+IN: binary-search
+
+<PRIVATE
+
+: midpoint ( seq -- elt )
+    [ midpoint@ ] keep nth-unsafe ; inline
+
+: decide ( quot seq -- quot seq <=> )
+    [ midpoint swap call ] 2keep rot ; inline
+
+: finish ( quot slice -- i elt )
+    [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
+    [ drop ] [ dup ] [ ] tri* nth ; inline
+
+: (search) ( quot seq -- i elt )
+    dup length 1 <= [
+        finish
+    ] [
+        decide {
+            { +eq+ [ finish ] }
+            { +lt+ [ dup midpoint@ head-slice (search) ] }
+            { +gt+ [ dup midpoint@ tail-slice (search) ] }
+        } case
+    ] if ; inline
+
+PRIVATE>
+
+: search ( seq quot -- i elt )
+    over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ;
+    inline
+
+: natural-search ( obj seq -- i elt )
+    [ <=> ] with search ;
+
+: sorted-index ( obj seq -- i )
+    natural-search drop ;
+
+: sorted-member? ( obj seq -- ? )
+    dupd natural-search nip = ;
+
+: sorted-memq? ( obj seq -- ? )
+    dupd natural-search nip eq? ;
--- a/core/compiler/tests/stack-trace.factor
+++ b/core/compiler/tests/stack-trace.factor
@ -30,10 +30,3 @@ words splitting grouping sorting ;
    \ + stack-trace-contains?
    \ > stack-trace-contains?
 ] unit-test
-
-: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
-
-[ t ] [
-    [ 10 quux ] ignore-errors
-    \ sort stack-trace-contains?
-] unit-test
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@ -143,6 +143,14 @@ IN: optimizer.known-words
    { [ dup optimize-instance? ] [ optimize-instance ] }
 } define-optimizers

+! This is a special-case hack
+: redundant-array-capacity-check? ( #call -- ? )
+    dup in-d>> first node-literal [ 0 = ] [ fixnum? ] bi and ;
+
+\ array-capacity? {
+    { [ dup redundant-array-capacity-check? ] [ [ drop t ] f splice-quot ] }
+} define-optimizers
+
 ! eq? on the same object is always t
 { eq? = } {
    { { @ @ } [ 2drop t ] }
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@ -219,7 +219,7 @@ M: number detect-number ;

 ! Regression
 USE: sorting
-USE: sorting.private
+USE: binary-search.private

 : old-binsearch ( elt quot seq -- elt quot i )
    dup length 1 <= [
@ -227,7 +227,7 @@ USE: sorting.private
    ] [
        [ midpoint swap call ] 3keep roll dup zero?
        [ drop dup slice-from swap midpoint@ + ]
-        [ partition old-binsearch ] if
+        [ dup midpoint@ cut-slice old-binsearch ] if
    ] if ; inline

 [ 10 ] [
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@ -243,6 +243,7 @@ $nl
 { $subsection "sequences-destructive" }
 { $subsection "sequences-stacks" }
 { $subsection "sequences-sorting" }
+{ $subsection "binary-search" }
 { $subsection "sets" }
 "For inner loops:"
 { $subsection "sequences-unsafe" } ;
@ -585,8 +586,6 @@ HELP: index
 { $values { "obj" object } { "seq" sequence } { "n" "an index" } }
 { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;

-{ index index-from last-index last-index-from member? memq? } related-words
-
 HELP: index-from
 { $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } }
 { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ", starting the search from the " { $snippet "i" } "th element. If no element is found, outputs " { $link f } "." } ;
--- a/core/sorting/sorting-docs.factor
+++ b/core/sorting/sorting-docs.factor
@ -2,18 +2,19 @@ USING: help.markup help.syntax kernel words math
 sequences math.order ;
 IN: sorting

-ARTICLE: "sequences-sorting" "Sorting and binary search"
-"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
+ARTICLE: "sequences-sorting" "Sorting sequences"
+"The " { $vocab-link "sorting" } " vocabulary implements the merge-sort algorithm. It runs in " { $snippet "O(n log n)" } " time, and is a " { $emphasis "stable" } " sort, meaning that the order of equal elements is preserved."
+$nl
+"The algorithm only allocates two additional arrays, both the size of the input sequence, and uses iteration rather than recursion, and thus is suitable for sorting large sequences."
+$nl
+"Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
 $nl
 "Sorting a sequence with a custom comparator:"
 { $subsection sort }
 "Sorting a sequence with common comparators:"
 { $subsection natural-sort }
 { $subsection sort-keys }
-{ $subsection sort-values }
-"Binary search:"
-{ $subsection binsearch }
-{ $subsection binsearch* } ;
+{ $subsection sort-values } ;

 ABOUT: "sequences-sorting"

@ -41,24 +42,4 @@ HELP: midpoint@
 { $values { "seq" "a sequence" } { "n" integer } }
 { $description "Outputs the index of the midpoint of " { $snippet "seq" } "." } ;

-HELP: midpoint
-{ $values { "seq" "a sequence" } { "elt" object } }
-{ $description "Outputs the element at the midpoint of a sequence." } ;
-
-HELP: partition
-{ $values { "seq" "a sequence" } { "n" integer } { "slice" slice } }
-{ $description "Outputs a slice of the first or second half of the sequence, respectively, depending on the integer's sign." } ;
-
-HELP: binsearch
-{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "i" "the index of the search result" } }
-{ $description "Given a sequence that is sorted with respect to the " { $snippet "quot" } " comparator, searches for an element equal to " { $snippet "elt" } ", or failing that, the greatest element smaller than " { $snippet "elt" } ". Comparison is performed with " { $snippet "quot" } "."
-$nl
-"Outputs f if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ;
-
-HELP: binsearch*
-{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "result" "the search result" } }
-{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
-$nl
-"Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ;
-
 { <=> compare natural-sort sort-keys sort-values } related-words
--- a/core/sorting/sorting-tests.factor
+++ b/core/sorting/sorting-tests.factor
@ -1,8 +1,8 @@
 USING: sorting sequences kernel math math.order random
-tools.test vectors ;
+tools.test vectors sets ;
 IN: sorting.tests

-[ [ ] ] [ [ ] natural-sort ] unit-test
+[ { } ] [ { } natural-sort ] unit-test

 [ { 270000000 270000001 } ]
 [ T{ slice f 270000000 270000002 270000002 } natural-sort ]
@ -11,18 +11,16 @@ unit-test
 [ t ] [
    100 [
        drop
-        100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic?
+        100 [ 20 random [ 1000 random ] replicate ] replicate
+        dup natural-sort
+        [ set= ] [ nip [ before=? ] monotonic? ] 2bi and
    ] all?
 ] unit-test

 [ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test

-[ 3 ] [ { 1 2 3 4 } midpoint ] unit-test
+! Is it a stable sort?
+[ t ] [ { { 1 "a" } { 1 "b" } { 1 "c" } } dup sort-keys = ] unit-test

-[ f ] [ 3 { } [ <=> ] binsearch ] unit-test
-[ 0 ] [ 3 { 3 } [ <=> ] binsearch ] unit-test
-[ 1 ] [ 2 { 1 2 3 } [ <=> ] binsearch ] unit-test
-[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] binsearch ] unit-test
-[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
-[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
-[ 10 ] [ 10 20 >vector [ <=> ] binsearch ] unit-test
+[ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ]
+[ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test
--- a/core/sorting/sorting.factor
+++ b/core/sorting/sorting.factor
@ -1,49 +1,142 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel math sequences vectors math.order
 sequences sequences.private math.order ;
 IN: sorting

-DEFER: sort
+! Optimized merge-sort:
+!
+! 1) only allocates 2 temporary arrays
+
+! 2) first phase (interchanging pairs x[i], x[i+1] where
+! x[i] > x[i+1]) is handled specially

 <PRIVATE

-: <iterator> 0 tail-slice ; inline
+TUPLE: merge
+{ seq    array }
+{ accum  vector }
+{ accum1 vector }
+{ accum2 vector }
+{ from1  array-capacity }
+{ to1    array-capacity }
+{ from2  array-capacity }
+{ to2    array-capacity } ;

-: this ( slice -- obj )
-    dup slice-from swap slice-seq nth-unsafe ; inline
-
-: next ( iterator -- )
-    dup slice-from 1+ swap set-slice-from ; inline
-
-: smallest ( iter1 iter2 quot -- elt )
-    >r over this over this r> call +lt+ eq?
-    -rot ? [ this ] keep next ; inline
-
-: (merge) ( iter1 iter2 quot accum -- )
-    >r pick empty? [
-        drop nip r> push-all
+: dump ( from to seq accum -- )
+    #! Optimize common case where to - from = 1, 2, or 3.
+    >r >r 2dup swap - dup 1 =
+    [ 2drop r> nth-unsafe r> push ] [
+        dup 2 = [
+            2drop dup 1+
+            r> [ nth-unsafe ] curry bi@
+            r> [ push ] curry bi@
        ] [
-        over empty? [
-            2drop r> push-all
+            dup 3 = [
+                2drop dup 1+ dup 1+
+                r> [ nth-unsafe ] curry tri@
+                r> [ push ] curry tri@
            ] [
-            3dup smallest r> [ push ] keep (merge)
+                drop r> subseq r> push-all
+            ] if
        ] if
    ] if ; inline

-: merge ( sorted1 sorted2 quot -- result )
-    >r [ [ <iterator> ] bi@ ] 2keep r>
-    rot length rot length + <vector>
-    [ (merge) ] [ underlying>> ] bi ; inline
+: l-elt   [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
+: r-elt   [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
+: l-done? [ from1>> ] [ to1>> ] bi number= ; inline
+: r-done? [ from2>> ] [ to2>> ] bi number= ; inline
+: dump-l  [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
+: dump-r  [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
+: l-next  [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
+: r-next  [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
+: decide  [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline

-: conquer ( first second quot -- result )
-    [ tuck >r >r sort r> r> sort ] keep merge ; inline
+: (merge) ( merge quot -- )
+    over r-done? [ drop dump-l ] [
+        over l-done? [ drop dump-r ] [
+            2dup decide
+            [ over r-next ] [ over l-next ] if
+            (merge)
+        ] if
+    ] if ; inline
+
+: flip-accum ( merge -- )
+    dup [ accum>> ] [ accum1>> ] bi eq? [
+        dup accum1>> underlying>> >>seq
+        dup accum2>> >>accum
+    ] [
+        dup accum1>> >>accum
+        dup accum2>> underlying>> >>seq
+    ] if
+    dup accum>> 0 >>length 2drop ; inline
+
+: <merge> ( seq -- merge )
+    \ merge new
+        over >vector >>accum1
+        swap length <vector> >>accum2
+        dup accum1>> underlying>> >>seq
+        dup accum2>> >>accum
+        dup accum>> 0 >>length drop ; inline
+
+: compute-midpoint ( merge -- merge )
+    dup [ from1>> ] [ to2>> ] bi + 2/ >>to1 ; inline
+
+: merging ( from to merge -- )
+    swap >>to2
+    swap >>from1
+    compute-midpoint
+    dup [ to1>> ] [ seq>> length ] bi min >>to1
+    dup [ to2>> ] [ seq>> length ] bi min >>to2
+    dup to1>> >>from2
+    drop ; inline
+
+: nth-chunk ( n size -- from to ) [ * dup ] keep + ; inline
+
+: chunks ( length size -- n ) [ align ] keep /i ; inline
+
+: each-chunk ( length size quot -- )
+    [ [ chunks ] keep ] dip
+    [ nth-chunk ] prepose curry
+    each-integer ; inline
+
+: merge ( from to merge quot -- )
+    [ [ merging ] keep ] dip (merge) ; inline
+
+: sort-pass ( merge size quot -- )
+    [
+        over flip-accum
+        over [ seq>> length ] 2dip
+    ] dip
+    [ merge ] 2curry each-chunk ; inline
+
+: sort-loop ( merge quot -- )
+    2 swap
+    [ pick seq>> length pick > ]
+    [ [ dup ] [ 1 shift ] [ ] tri* [ sort-pass ] 2keep ]
+    [ ] while 3drop ; inline
+
+: each-pair ( seq quot -- )
+    [ [ length 1+ 2/ ] keep ] dip
+    [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
+
+: (sort-pairs) ( i1 i2 seq quot accum -- )
+    >r >r 2dup length = [
+        nip nth r> drop r> push
+    ] [
+        tuck [ nth-unsafe ] 2bi@ 2dup r> call +gt+ eq?
+        [ swap ] when r> tuck [ push ] 2bi@
+    ] if ; inline
+
+: sort-pairs ( merge quot -- )
+    [ [ seq>> ] [ accum>> ] bi ] dip swap
+    [ (sort-pairs) ] 2curry each-pair ; inline

 PRIVATE>

-: sort ( seq quot -- sortedseq )
-    over length 1 <=
-    [ drop ] [ over >r >r halves r> conquer r> like ] if ;
+: sort ( seq quot -- seq' )
+    [ <merge> ] dip
+    [ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ;
    inline

 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
@ -53,25 +146,3 @@ PRIVATE>
 : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;

 : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
-
-: midpoint ( seq -- elt )
-    [ midpoint@ ] keep nth-unsafe ; inline
-
-: partition ( seq n -- slice )
-    +gt+ eq? not swap halves ? ; inline
-
-: (binsearch) ( elt quot seq -- i )
-    dup length 1 <= [
-        slice-from 2nip
-    ] [
-        [ midpoint swap call ] 3keep roll dup +eq+ eq?
-        [ drop dup slice-from swap midpoint@ + 2nip ]
-        [ partition (binsearch) ] if
-    ] if ; inline
-
-: binsearch ( elt seq quot -- i )
-    swap dup empty?
-    [ 3drop f ] [ <flat-slice> (binsearch) ] if ; inline
-
-: binsearch* ( elt seq quot -- result )
-    over >r binsearch [ r> ?nth ] [ r> drop f ] if* ; inline
--- a/extra/automata/ui/ui.factor
+++ b/extra/automata/ui/ui.factor
@ -6,7 +6,6 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
       ui
       ui.gestures
       ui.gadgets
-       ui.gadgets.handler
       ui.gadgets.slate
       ui.gadgets.labels
       ui.gadgets.buttons
@ -14,8 +13,8 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
       ui.gadgets.packs
       ui.gadgets.grids
       ui.gadgets.theme
+       ui.gadgets.handler
       accessors
-       qualified
       namespaces.lib assocs.lib vars
       rewrite-closures automata math.geometry.rect newfx ;

@ -23,13 +22,6 @@ IN: automata.ui

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-QUALIFIED: ui.gadgets.grids
-
-: grid-add ( grid child i j -- grid )
-  >r >r dupd swap r> r> ui.gadgets.grids:grid-add ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;

 : draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
@ -80,13 +72,15 @@ DEFER: automata-window
      "5 - Random Rule" [ random-rule     ] view-button add-gadget
      "n - New"         [ automata-window ] view-button add-gadget

-    @top grid-add
+    @top grid-add*

    C[ display ] <slate>
-      { 400 400 } >>dim
+      { 400 400 } >>pdim
    dup >slate

-    @center grid-add
+    @center grid-add*
+
+  <handler>

  H{ }
    T{ key-down f f "1" } [ start-center    ] view-action is
@ -95,9 +89,7 @@ DEFER: automata-window
    T{ key-down f f "5" } [ random-rule     ] view-action is
    T{ key-down f f "n" } [ automata-window ] view-action is

-  <handler>
-
-    tuck set-gadget-delegate
+  >>table

  "Automata" open-window ;

--- a/extra/benchmark/backtrack/backtrack.factor
+++ b/extra/benchmark/backtrack/backtrack.factor
@ -0,0 +1,67 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: backtrack shuffle math math.ranges quotations locals fry
+kernel words io memoize macros io prettyprint sequences assocs
+combinators namespaces ;
+IN: benchmark.backtrack
+
+! This was suggested by Dr_Ford. Compute the number of quadruples
+! (a,b,c,d) with 1 <= a,b,c,d <= 10 such that we can make 24 by
+! placing them on the stack, and applying the operations
+! +, -, * and rot as many times as we wish.
+
+: nop ;
+
+MACRO: amb-execute ( seq -- quot )
+    [ length ] [ <enum> [ 1quotation ] assoc-map ] bi
+    '[ , amb , case ] ;
+
+: if-amb ( true false -- )
+    [
+        [ { t f } amb ]
+        [ '[ @ require t ] ]
+        [ '[ @ f ] ]
+        tri* if
+    ] with-scope ; inline
+
+: do-something ( a b -- c )
+    { + - * } amb-execute ;
+
+: some-rots ( a b c -- a b c )
+    #! Try to rot 0, 1 or 2 times.
+    { nop rot -rot } amb-execute ;
+
+MEMO: 24-from-1 ( a -- ? )
+    24 = ;
+
+MEMO: 24-from-2 ( a b -- ? )
+    [ do-something 24-from-1 ] [ 2drop ] if-amb ;
+
+MEMO: 24-from-3 ( a b c -- ? )
+    [ some-rots do-something 24-from-2 ] [ 3drop ] if-amb ;
+
+MEMO: 24-from-4 ( a b c d -- ? )
+    [ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ;
+
+: find-impossible-24 ( -- n )
+    1 10 [a,b] [| a |
+        1 10 [a,b] [| b |
+            1 10 [a,b] [| c |
+                1 10 [a,b] [| d |
+                    a b c d 24-from-4
+                ] count
+            ] sigma
+        ] sigma
+    ] sigma ;
+
+: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ;
+
+: backtrack-benchmark ( -- )
+    words [ reset-memoized ] each
+    find-impossible-24 pprint "/10000 quadruples can make 24." print
+    words [
+        dup pprint " tested " write "memoize" word-prop assoc-size pprint
+        " possibilities" print
+    ] each ;
+
+MAIN: backtrack-benchmark
--- a/extra/boids/ui/ui.factor
+++ b/extra/boids/ui/ui.factor
@ -102,7 +102,7 @@ VARS: population-label cohesion-label alignment-label separation-label ;

  C[ display ] <slate> >slate
    t                      slate> set-gadget-clipped?
-    { 600 400 }            slate> set-slate-dim
+    { 600 400 }            slate> set-slate-pdim
    C[ [ run ] in-thread ] slate> set-slate-graft
    C[ loop off ]          slate> set-slate-ungraft

@ -143,9 +143,11 @@ VARS: population-label cohesion-label alignment-label separation-label ;

  } [ call ] map [ add-gadget ] each
    1 over set-pack-fill
-    over @top grid-add
+    @top grid-add*

-  slate> over @center grid-add
+  slate> @center grid-add*
+
+  <handler> 

  H{ } clone
    T{ key-down f f "1" } C[ drop randomize    ] is
@ -162,7 +164,10 @@ VARS: population-label cohesion-label alignment-label separation-label ;
    T{ key-down f f "d" } C[ drop dec-separation-weight ] is

    T{ key-down f f "ESC" } C[ drop toggle-loop ] is
-  <handler> tuck set-gadget-delegate "Boids" open-window ;
+
+  >>table
+
+  "Boids" open-window ;

 : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;

--- a/extra/cfdg/cfdg.factor
+++ b/extra/cfdg/cfdg.factor
@ -204,7 +204,7 @@ VAR: start-shape

 : cfdg-window* ( -- )
  [ display ] closed-quot <slate>
-  { 500 500 } over set-slate-dim
+  { 500 500 } over set-slate-pdim
  dup "CFDG" open-window ;

 : cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
--- a/extra/channels/channels-tests.factor
+++ b/extra/channels/channels-tests.factor
@ -17,7 +17,7 @@ IN: channels.tests
    from 
 ] unit-test

-{ V{ 1 2 3 4 } } [
+{ { 1 2 3 4 } } [
    V{ } clone <channel>
    [ from swap push ] in-thread
    [ from swap push ] in-thread
@ -30,7 +30,7 @@ IN: channels.tests
    natural-sort
 ] unit-test

-{ V{ 1 2 4 9 } } [
+{ { 1 2 4 9 } } [
    V{ } clone <channel>
    [ 4 swap to ] in-thread
    [ 2 swap to ] in-thread
--- a/extra/cords/cords.factor
+++ b/extra/cords/cords.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sequences sorting math math.order
-arrays combinators kernel ;
+USING: accessors assocs sequences sorting binary-search math
+math.order arrays combinators kernel ;
 IN: cords

 <PRIVATE
@ -23,7 +23,7 @@ M: multi-cord length count>> ;

 M: multi-cord virtual@
    dupd
-    seqs>> [ first <=> ] binsearch*
+    seqs>> [ first <=> ] with search nip
    [ first - ] [ second ] bi ;

 M: multi-cord virtual-seq
--- a/extra/display-stack/display-stack.factor
+++ b/extra/display-stack/display-stack.factor
@ -0,0 +1,43 @@
+
+USING: kernel namespaces sequences math
+       listener io prettyprint sequences.lib fry ;
+
+IN: display-stack
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: watched-variables
+
+: watch-var ( sym -- ) watched-variables get push ;
+
+: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
+
+: unwatch-var ( sym -- ) watched-variables get delete ;
+
+: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
+
+: print-watched-variables ( -- )
+  watched-variables get length 0 >
+    [
+      "----------" print
+      watched-variables get
+        watched-variables get [ unparse ] map longest length 2 +
+        '[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ]
+      each
+
+    ]
+  when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: display-stack ( -- )
+  V{ } clone watched-variables set
+    [
+      print-watched-variables
+      "----------" print
+      datastack [ . ] each
+      "----------" print
+      retainstack reverse [ . ] each
+    ]
+  listener-hook set ;
+
--- a/extra/farkup/authors.factor
+++ b/extra/farkup/authors.factor
@ -1,2 +0,0 @@
-Doug Coleman
-Slava Pestov
--- a/extra/farkup/authors.txt
+++ b/extra/farkup/authors.txt
@ -1 +1,2 @@
 Doug Coleman
+Slava Pestov
--- a/extra/farkup/farkup-tests.factor
+++ b/extra/farkup/farkup-tests.factor
@ -1,12 +1,19 @@
-USING: farkup kernel tools.test ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: farkup kernel peg peg.ebnf tools.test ;
 IN: farkup.tests

-[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
-[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" convert-farkup ] unit-test
-[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
-[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+[ ] [
+    "abcd-*strong*\nasdifj\nweouh23ouh23"
+    "paragraph" \ farkup rule parse drop
+] unit-test

-[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+[ ] [
+    "abcd-*strong*\nasdifj\nweouh23ouh23\n"
+    "paragraph" \ farkup rule parse drop
+] unit-test
+
+[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
 [ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test
 [ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test
 [ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test
@ -15,11 +22,20 @@ IN: farkup.tests
 [ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test
 [ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test

-[ "" ] [ "\n\n" convert-farkup ] unit-test
-[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
-[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
-[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
-[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
+[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
+[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n</ul>" ] [ "-foo\n" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n<li>bar</li>\n</ul>" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+
+[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+
+
+[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
+[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
+[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
+[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
+[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
@ -29,7 +45,7 @@ IN: farkup.tests
 [ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
 [ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test

-[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test

 [ "" ] [ "" convert-farkup ] unit-test

@ -77,8 +93,5 @@ IN: farkup.tests
 ] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test

 [
-    "<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+    "<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
 ] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
-
-[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
-[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@ -1,72 +1,111 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.styles kernel memoize namespaces peg math
-combinators sequences strings html.elements xml.entities
-xmode.code2html splitting io.streams.string peg.parsers
-sequences.deep unicode.categories ;
+USING: accessors arrays combinators html.elements io io.streams.string
+kernel math memoize namespaces peg peg.ebnf prettyprint
+sequences sequences.deep strings xml.entities vectors splitting
+xmode.code2html ;
 IN: farkup

 SYMBOL: relative-link-prefix
 SYMBOL: disable-images?
 SYMBOL: link-no-follow?

-<PRIVATE
+TUPLE: heading1 obj ;
+TUPLE: heading2 obj ;
+TUPLE: heading3 obj ;
+TUPLE: heading4 obj ;
+TUPLE: strong obj ;
+TUPLE: emphasis obj ;
+TUPLE: superscript obj ;
+TUPLE: subscript obj ;
+TUPLE: inline-code obj ;
+TUPLE: paragraph obj ;
+TUPLE: list-item obj ;
+TUPLE: list obj ;
+TUPLE: table obj ;
+TUPLE: table-row obj ;
+TUPLE: link href text ;
+TUPLE: image href text ;
+TUPLE: code mode string ;

-: delimiters ( -- string )
-    "*_^~%[-=|\\\r\n" ; inline
+EBNF: farkup
+nl               = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
+2nl              = nl nl

-MEMO: text ( -- parser )
-    [ delimiters member? not ] satisfy repeat1
-    [ >string escape-string ] action ;
+heading1      = "=" (!("=" | nl).)+ "="
+    => [[ second >string heading1 boa ]]

-MEMO: delimiter ( -- parser )
-    [ dup delimiters member? swap "\r\n=" member? not and ] satisfy
-    [ 1string ] action ;
+heading2      = "==" (!("=" | nl).)+ "=="
+    => [[ second >string heading2 boa ]]

-: surround-with-foo ( string tag -- seq )
-    dup <foo> swap </foo> swapd 3array ;
+heading3      = "===" (!("=" | nl).)+ "==="
+    => [[ second >string heading3 boa ]]

-: delimited ( str html -- parser )
-    [
-        over token hide ,
-        text [ surround-with-foo ] swapd curry action ,
-        token hide ,
-    ] seq* ;
+heading4      = "====" (!("=" | nl).)+ "===="
+    => [[ second >string heading4 boa ]]

-MEMO: escaped-char ( -- parser )
-    [ "\\" token hide , any-char , ] seq* [ >string ] action ;
+strong        = "*" (!("*" | nl).)+ "*"
+    => [[ second >string strong boa ]]

-MEMO: strong ( -- parser ) "*" "strong" delimited ;
-MEMO: emphasis ( -- parser ) "_" "em" delimited ;
-MEMO: superscript ( -- parser ) "^" "sup" delimited ;
-MEMO: subscript ( -- parser ) "~" "sub" delimited ;
-MEMO: inline-code ( -- parser ) "%" "code" delimited ;
-MEMO: nl ( -- parser )
-    "\r\n" token [ drop "\n" ] action
-    "\r" token [ drop "\n" ] action
-    "\n" token 3choice ;
-MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
-MEMO: h1 ( -- parser ) "=" "h1" delimited ;
-MEMO: h2 ( -- parser ) "==" "h2" delimited ;
-MEMO: h3 ( -- parser ) "===" "h3" delimited ;
-MEMO: h4 ( -- parser ) "====" "h4" delimited ;
+emphasis      = "_" (!("_" | nl).)+ "_"
+    => [[ second >string emphasis boa ]]
+
+superscript   = "^" (!("^" | nl).)+ "^"
+    => [[ second >string superscript boa ]]
+
+subscript     = "~" (!("~" | nl).)+ "~"
+    => [[ second >string subscript boa ]]
+
+inline-code   = "%" (!("%" | nl).)+ "%"
+    => [[ second >string inline-code boa ]]
+
+escaped-char  = "\" .                => [[ second ]]
+
+image-link       = "[[image:" (!("|") .)+  "|" (!("]]").)+ "]]"
+                    => [[ [ second >string ] [ fourth >string ] bi image boa ]]
+                  | "[[image:" (!("]").)+ "]]"
+                    => [[ second >string f image boa ]]
+
+simple-link      = "[[" (!("|]" | "]]") .)+ "]]"
+    => [[ second >string dup link boa ]]
+
+labelled-link    = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
+    => [[ [ second >string ] [ fourth >string ] bi link boa ]]
+
+link             = image-link | labelled-link | simple-link
+
+heading          = heading4 | heading3 | heading2 | heading1
+
+inline-tag       = strong | emphasis | superscript | subscript | inline-code
+                   | link | escaped-char
+
+inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
+
+table-column     = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter  ) '|'
+    => [[ first ]]
+table-row        = "|" (table-column)+
+    => [[ second table-row boa ]]
+table            =  ((table-row nl => [[ first ]] )+ table-row? | table-row)
+    => [[ table boa ]]
+
+paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
+paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
+             | (paragraph-item nl)+ paragraph-item?
+             | paragraph-item)
+    => [[ paragraph boa ]]
+                
+list-item      = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
+    => [[ second list-item boa ]]
+list = ((list-item nl)+ list-item? | list-item)
+    => [[ list boa ]]
+
+code       =  '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
+    => [[ [ second >string ] [ fourth >string ] bi code boa ]]
+
+stand-alone      = (code | heading | list | table | paragraph | nl)*
+;EBNF

-MEMO: eq ( -- parser )
-    [
-        h1 ensure-not ,
-        h2 ensure-not ,
-        h3 ensure-not ,
-        h4 ensure-not ,
-        "=" token ,
-    ] seq* ;

-: render-code ( string mode -- string' )
-    >r string-lines r>
-    [
-        <pre>
-            htmlize-lines
-        </pre>
-    ] with-string-writer ;

 : invalid-url "javascript:alert('Invalid URL in farkup');" ;

@ -85,116 +124,57 @@ MEMO: eq ( -- parser )
 : escape-link ( href text -- href-esc text-esc )
    >r check-url escape-quoted-string r> escape-string ;

-: make-link ( href text -- seq )
+: write-link ( text href -- )
    escape-link
-    [
-        "<a" ,
-        " href=\"" , >r , r> "\"" ,
-        link-no-follow? get [ " nofollow=\"true\"" , ] when
-        ">" , , "</a>" ,
-    ] { } make ;
+    "<a" write
+    " href=\"" write write "\"" write
+    link-no-follow? get [ " nofollow=\"true\"" write ] when
+    ">" write write "</a>" write ;

-: make-image-link ( href alt -- seq )
+: write-image-link ( href text -- )
    disable-images? get [
-        2drop "<strong>Images are not allowed</strong>"
+        2drop "<strong>Images are not allowed</strong>" write
    ] [
        escape-link
-        [
-            "<img src=\"" , swap , "\"" ,
-            dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
-            "/>" ,
-        ] { } make
+        >r "<img src=\"" write write "\"" write r>
+        dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
+        "/>" write
    ] if ;

-MEMO: image-link ( -- parser )
+: render-code ( string mode -- string' )
+    >r string-lines r>
    [
-        "[[image:" token hide ,
-        [ "|]" member? not ] satisfy repeat1 [ >string ] action ,
-        "|" token hide
-            [ CHAR: ] = not ] satisfy repeat0 2seq
-            [ first >string ] action optional ,
-        "]]" token hide ,
-    ] seq* [ first2 make-image-link ] action ;
+        <pre>
+            htmlize-lines
+        </pre>
+    ] with-string-writer write ;

-MEMO: simple-link ( -- parser )
-    [
-        "[[" token hide ,
-        [ "|]" member? not ] satisfy repeat1 ,
-        "]]" token hide ,
-    ] seq* [ first dup make-link ] action ;
-
-MEMO: labelled-link ( -- parser )
-    [
-        "[[" token hide ,
-        [ CHAR: | = not ] satisfy repeat1 ,
-        "|" token hide ,
-        [ CHAR: ] = not ] satisfy repeat1 ,
-        "]]" token hide ,
-    ] seq* [ first2 make-link ] action ;
-
-MEMO: link ( -- parser )
-    [ image-link , simple-link , labelled-link , ] choice* ;
-
-DEFER: line
-MEMO: list-item ( -- parser )
-    [
-        "-" token hide , ! text ,
-        [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
-    ] seq* [ "li" surround-with-foo ] action ;
-
-MEMO: list ( -- parser )
-    list-item nl hide list-of
-    [ "ul" surround-with-foo ] action ;
-
-MEMO: table-column ( -- parser )
-    text [ "td" surround-with-foo ] action ;
-
-MEMO: table-row ( -- parser )
-    "|" token hide
-    table-column "|" token hide list-of
-    "|" token hide nl hide optional 4seq
-    [ "tr" surround-with-foo ] action ;
-
-MEMO: table ( -- parser )
-    table-row repeat1
-    [ "table" surround-with-foo ] action ;
-
-MEMO: code ( -- parser )
-    [
-        "[" token hide ,
-        [ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
-        "{" token hide ,
-        "}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
-        "}]" token hide ,
-    ] seq* [ first2 swap render-code ] action ;
-
-MEMO: line ( -- parser )
-    [
-        nl table 2seq ,
-        nl list 2seq ,
-        text , strong , emphasis , link ,
-        superscript , subscript , inline-code ,
-        escaped-char , delimiter , eq ,
-    ] choice* repeat1 ;
-
-MEMO: paragraph ( -- parser )
-    line
-    nl over 2seq repeat0
-    nl nl ensure-not 2seq optional 3seq
-    [
-        dup [ dup string? not swap [ blank? ] all? or ] deep-all?
-        [ "<p>" swap "</p>" 3array ] unless
-    ] action ;
-
-PRIVATE>
-
-PEG: parse-farkup ( -- parser )
-    [
-        list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
-    ] choice* repeat0 nl optional 2seq ;
-
-: write-farkup ( parse-result  -- )
-    [ dup string? [ write ] [ drop ] if ] deep-each ;
+GENERIC: write-farkup ( obj -- )
+: <foo.> ( string -- ) <foo> write ;
+: </foo.> ( string -- ) </foo> write ;
+: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
+M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
+M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
+M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
+M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
+M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
+M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
+M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
+M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
+M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
+M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
+M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
+M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
+M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
+M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
+M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
+M: table-row write-farkup ( obj -- )
+    obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
+M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
+M: fixnum write-farkup ( obj -- ) write1 ;
+M: string write-farkup ( obj -- ) write ;
+M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
+M: f write-farkup ( obj -- ) drop ;

 : convert-farkup ( string -- string' )
-    parse-farkup [ write-farkup ] with-string-writer ;
+    farkup [ write-farkup ] with-string-writer ;
--- a/extra/golden-section/golden-section.factor
+++ b/extra/golden-section/golden-section.factor
@ -1,64 +1,64 @@
+
 USING: kernel namespaces math math.constants math.functions arrays sequences
       opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
-    ui.gadgets.slate colors ;
+       ui.gadgets.slate colors accessors combinators.cleave ;
+
 IN: golden-section

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-! To run:
-! "golden-section" run
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: disk ( quadric radius center -- )
+: disk ( radius center -- )
  glPushMatrix
  gl-translate
  dup 0 glScalef
-    0 1 10 10 gluDisk
+  gluNewQuadric [ 0 1 20 20 gluDisk ] [ gluDeleteQuadric ] bi
  glPopMatrix ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

+! omega(i) = 2*pi*i*(phi-1)
+
+! x(i) = 0.5*i*cos(omega(i))
+! y(i) = 0.5*i*sin(omega(i))
+
+! radius(i) = 10*sin((pi*i)/720)
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : omega ( i -- omega ) phi 1- * 2 * pi * ;

-: x ( i -- x ) dup omega cos * 0.5 * ;
+: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
+: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ;

-: y ( i -- y ) dup omega sin * 0.5 * ;
-
-: center ( i -- point ) dup x swap y 2array ;
+: center ( i -- point ) { x y } 1arr ;

 : radius ( i -- radius ) pi * 720 / sin 10 * ;

 : color ( i -- color ) 360.0 / dup 0.25 1 4array ;

-: rim ( quadric i -- )
-    black gl-color dup radius 1.5 * swap center disk ;
+: rim   ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ;
+: inner ( i -- ) [      color gl-color ] [ radius       ] [ center ] tri disk ;

-: inner ( quadric i -- )
-    dup color gl-color dup radius swap center disk ;
+: dot ( i -- ) [ rim ] [ inner ] bi ;

-: dot ( quadric i -- ) 2dup rim inner ;
-
-: golden-section ( quadric -- ) 720 [ dot ] with each ;
+: golden-section ( -- ) 720 [ dot ] each ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-: with-quadric ( quot -- )
-    gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline
-
 : display ( -- )
  GL_PROJECTION glMatrixMode
  glLoadIdentity
  -400 400 -400 400 -1 1 glOrtho
  GL_MODELVIEW glMatrixMode
  glLoadIdentity
-    [ golden-section ] with-quadric ;
+  golden-section ;

 : golden-section-window ( -- )
    [
      [ display ] <slate>
-        { 600 600 } over set-slate-dim
+        { 600 600 } >>pdim
      "Golden Section" open-window
-    ] with-ui ;
+    ]
+  with-ui ;

 MAIN: golden-section-window
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@ -188,6 +188,9 @@ M: f print-element drop ;
 : $links ( topics -- )
    [ [ ($link) ] textual-list ] ($span) ;

+: $vocab-links ( vocabs -- )
+    [ vocab ] map $links ;
+
 : $see-also ( topics -- )
    "See also" $heading $links ;

--- a/extra/html/components/components-tests.factor
+++ b/extra/html/components/components-tests.factor
@ -155,7 +155,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;

 [ ] [ "-foo\n-bar" "farkup" set-value ] unit-test

-[ "<ul><li>foo</li><li>bar</li></ul>" ] [
+[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [
    [ "farkup" T{ farkup } render ] with-string-writer
 ] unit-test

--- a/extra/interval-maps/interval-maps.factor
+++ b/extra/interval-maps/interval-maps.factor
@ -1,5 +1,7 @@
-USING: kernel sequences arrays accessors grouping
-math.order sorting math assocs locals namespaces ;
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences arrays accessors grouping math.order
+sorting binary-search math assocs locals namespaces ;
 IN: interval-maps

 TUPLE: interval-map array ;
@ -7,7 +9,7 @@ TUPLE: interval-map array ;
 <PRIVATE

 : find-interval ( key interval-map -- interval-node )
-    [ first <=> ] binsearch* ;
+    [ first <=> ] with search nip ;

 : interval-contains? ( key interval-node -- ? )
    first2 between? ;
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
       accessors destructors namespaces io assocs arrays qualified fry
-       continuations threads strings classes combinators
-       irc.messages irc.messages.private ;
+       continuations threads strings classes combinators splitting hashtables
+       ascii irc.messages irc.messages.private ;
 RENAME: join sequences => sjoin
 EXCLUDE: sequences => join ;
 IN: irc.client
@ -27,7 +27,7 @@ TUPLE: irc-client profile stream in-messages out-messages join-messages

 TUPLE: irc-listener in-messages out-messages ;
 TUPLE: irc-server-listener < irc-listener ;
-TUPLE: irc-channel-listener < irc-listener name password timeout ;
+TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
 TUPLE: irc-nick-listener < irc-listener name ;
 SYMBOL: +server-listener+

@ -37,10 +37,10 @@ SYMBOL: +server-listener+
     <mailbox> <mailbox> irc-server-listener boa ;

 : <irc-channel-listener> ( name -- irc-channel-listener )
-     <mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
+     [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ;

 : <irc-nick-listener> ( name -- irc-nick-listener )
-     <mailbox> <mailbox> rot irc-nick-listener boa ;
+     [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;

 ! ======================================
 ! Message objects
@ -52,8 +52,8 @@ SINGLETON: irc-connected    ! sent when connection is established
 UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;

 : terminate-irc ( irc-client -- )
-    [ in-messages>> irc-end swap mailbox-put ]
-    [ f >>is-running drop ]
+    [ [ irc-end ] dip in-messages>> mailbox-put ]
+    [ [ f ] dip (>>is-running) ]
    [ stream>> dispose ]
    tri ;

@ -74,18 +74,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
    listener> [ +server-listener+ listener> ] unless*
    [ in-messages>> mailbox-put ] [ drop ] if* ;

+: remove-participant ( nick channel -- )
+    listener> [ participants>> delete-at ] [ drop ] if* ;
+
+: remove-participant-from-all ( nick -- )
+    irc> listeners>>
+    [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
+    assoc-each ;
+
+: add-participant ( nick mode channel -- )
+    listener> [ participants>> set-at ] [ 2drop ] if* ;
+
+DEFER: me?
+
+: maybe-forward-join ( join -- )
+    [ prefix>> parse-name me? ] keep and
+    [ irc> join-messages>> mailbox-put ] when* ;
+
 ! ======================================
 ! IRC client messages
 ! ======================================

-GENERIC: irc-message>string ( irc-message -- string )
-
-M: irc-message irc-message>string ( irc-message -- string )
-    [ command>> ]
-    [ parameters>> " " sjoin ]
-    [ trailing>> dup [ CHAR: : prefix ] when ]
-    tri 3array " " sjoin ;
-
 : /NICK ( nick -- )
    "NICK " irc-write irc-print ;

@ -99,7 +108,7 @@ M: irc-message irc-message>string ( irc-message -- string )

 : /JOIN ( channel password -- )
    "JOIN " irc-write
-    [ " :" swap 3append ] when* irc-print ;
+    [ [ " :" ] dip 3append ] when* irc-print ;

 : /PART ( channel text -- )
    [ "PART " irc-write irc-write ] dip
@ -153,17 +162,34 @@ M: privmsg handle-incoming-irc ( privmsg -- )
    dup irc-message-origin to-listener ;

 M: join handle-incoming-irc ( join -- )
-    [ [ prefix>> parse-name me? ] keep and
-      [ irc> join-messages>> mailbox-put ] when* ]
+    [ maybe-forward-join ]
    [ dup trailing>> to-listener ]
-    bi ;
+    [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
+    tri ;

 M: part handle-incoming-irc ( part -- )
-    dup channel>> to-listener ;
+    [ dup channel>> to-listener ] keep
+    [ prefix>> parse-name ] [ channel>> ] bi remove-participant ;

 M: kick handle-incoming-irc ( kick -- )
-    [ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when
-    to-listener ;
+    [ dup channel>>  to-listener ]
+    [ [ who>> ] [ channel>> ] bi remove-participant ] 
+    [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+    tri ;
+
+M: quit handle-incoming-irc ( quit -- )
+    [ prefix>> parse-name remove-participant-from-all ] keep
+    call-next-method ;
+
+: >nick/mode ( string -- nick mode )
+    dup first "+@" member? [ unclip ] [ f ] if ;
+
+: names-reply>participants ( names-reply -- participants )
+    trailing>> [ blank? ] trim " " split
+    [ >nick/mode 2array ] map >hashtable ;
+
+M: names-reply handle-incoming-irc ( names-reply -- )
+    [ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ;

 M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
    broadcast-message-to-listeners ;
@ -180,7 +206,7 @@ GENERIC: handle-outgoing-irc ( obj -- )
 M: privmsg handle-outgoing-irc ( privmsg -- )
    [ name>> ] [ trailing>> ] bi /PRIVMSG ;

-M: part handle-outgoing-irc ( privmsg -- )
+M: part handle-outgoing-irc ( part -- )
    [ channel>> ] [ trailing>> "" or ] bi /PART ;

 ! ======================================
@ -188,8 +214,8 @@ M: part handle-outgoing-irc ( privmsg -- )
 ! ======================================

 : irc-mailbox-get ( mailbox quot -- )
-    swap 5 seconds
-    '[ , , , mailbox-get-timeout swap call ]
+    [ 5 seconds ] dip
+    '[ , , ,  [ mailbox-get-timeout ] dip call ]
    [ drop ] recover ; inline

 : handle-reader-message ( irc-message -- )
@ -199,11 +225,12 @@ DEFER: (connect-irc)

 : (handle-disconnect) ( -- )
    irc>
-        [ in-messages>> irc-disconnected swap mailbox-put ]
+        [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
        [ dup reconnect-time>> sleep (connect-irc) ]
        [ profile>> nickname>> /LOGIN ]
    tri ;

+! FIXME: do something with the exception, store somewhere to help debugging
 : handle-disconnect ( error -- )
    drop irc> is-running>> [ (handle-disconnect) ] when ;

@ -236,6 +263,7 @@ DEFER: (connect-irc)
    {
        { [ dup string? ] [ strings>privmsg ] }
        { [ dup privmsg instance? ] [ swap >>name ] }
+        [ nip ]
    } cond ;

 : listener-loop ( name listener -- )
@ -275,7 +303,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
    [ name>> ] keep set+run-listener ;

 M: irc-server-listener (add-listener) ( irc-server-listener -- )
-    +server-listener+ swap set+run-listener ;
+    [ +server-listener+ ] dip set+run-listener ;

 GENERIC: (remove-listener) ( irc-listener -- )

@ -283,8 +311,8 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
    name>> unregister-listener ;

 M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
-    [ [ out-messages>> ] [ name>> ] bi
-      \ part new swap >>channel mailbox-put ] keep
+    [ [ name>> ] [ out-messages>> ] bi
+      [ [ part new ] dip >>channel ] dip mailbox-put ] keep
    name>> unregister-listener ;

 M: irc-server-listener (remove-listener) ( irc-server-listener -- )
@ -294,10 +322,10 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
    [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
        swap >>stream
        t >>is-running
-    in-messages>> irc-connected swap mailbox-put ;
+    in-messages>> [ irc-connected ] dip mailbox-put ;

 : with-irc-client ( irc-client quot -- )
-    >r current-irc-client r> with-variable ; inline
+    [ current-irc-client ] dip with-variable ; inline

 PRIVATE>

--- a/extra/irc/messages/messages.factor
+++ b/extra/irc/messages/messages.factor
@ -1,13 +1,15 @@
 ! Copyright (C) 2008 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel fry sequences splitting ascii calendar accessors combinators
-       classes.tuple math.order ;
+USING: kernel fry splitting ascii calendar accessors combinators qualified
+       arrays classes.tuple math.order ;
+RENAME: join sequences => sjoin
+EXCLUDE: sequences => join ;
 IN: irc.messages

 TUPLE: irc-message line prefix command parameters trailing timestamp ;
 TUPLE: logged-in < irc-message name ;
 TUPLE: ping < irc-message ;
-TUPLE: join < irc-message channel ;
+TUPLE: join < irc-message ;
 TUPLE: part < irc-message channel ;
 TUPLE: quit < irc-message ;
 TUPLE: privmsg < irc-message name ;
@ -16,8 +18,21 @@ TUPLE: roomlist < irc-message channel names ;
 TUPLE: nick-in-use < irc-message asterisk name ;
 TUPLE: notice < irc-message type ;
 TUPLE: mode < irc-message name channel mode ;
+TUPLE: names-reply < irc-message who = channel ;
 TUPLE: unhandled < irc-message ;

+GENERIC: irc-message>client-line ( irc-message -- string )
+
+M: irc-message irc-message>client-line ( irc-message -- string )
+    [ command>> ]
+    [ parameters>> " " sjoin ]
+    [ trailing>> dup [ CHAR: : prefix ] when ]
+    tri 3array " " sjoin ;
+
+GENERIC: irc-message>server-line ( irc-message -- string )
+M: irc-message irc-message>server-line ( irc-message -- string )
+   drop "not implemented yet" ;
+
 <PRIVATE
 ! ======================================
 ! Message parsing
@ -55,6 +70,7 @@ TUPLE: unhandled < irc-message ;
        { "NOTICE" [ \ notice ] }
        { "001" [ \ logged-in ] }
        { "433" [ \ nick-in-use ] }
+        { "353" [ \ names-reply ] }
        { "JOIN" [ \ join ] }
        { "PART" [ \ part ] }
        { "PRIVMSG" [ \ privmsg ] }
--- a/extra/irc/ui/commandparser/commandparser.factor
+++ b/extra/irc/ui/commandparser/commandparser.factor
@ -0,0 +1,17 @@
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel vocabs.loader sequences strings splitting words irc.messages ;
+
+IN: irc.ui.commandparser
+
+"irc.ui.commands" require
+
+: command ( string string -- string command )
+    dup empty? [ drop "say" ] when
+    dup "irc.ui.commands" lookup
+    [ nip ]
+    [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;
+
+: parse-message ( string -- )
+    "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;
--- a/extra/irc/ui/commands/commands.factor
+++ b/extra/irc/ui/commands/commands.factor
@ -0,0 +1,13 @@
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
+
+IN: irc.ui.commands
+
+: say ( string -- )
+    [ client get profile>> nickname>> <own-message> print-irc ]
+    [ listener get write-message ] bi ;
+
+: quote ( string -- )
+    drop ; ! THIS WILL CHANGE
--- a/extra/irc/ui/ircui-rc
+++ b/extra/irc/ui/ircui-rc
@ -0,0 +1,9 @@
+! Default system ircui-rc file
+! Copy into .ircui-rc in your home directory and then change username and such
+! To find your home directory, type "home ." into a Factor listener
+
+USING: irc.client irc.ui ;
+
+"irc.freenode.org" 8001 "factor-irc" f ! server port nick password
+{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin
+server-open
--- a/extra/irc/ui/load/load.factor
+++ b/extra/irc/ui/load/load.factor
@ -0,0 +1,16 @@
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel io.files parser editors sequences ;
+
+IN: irc.ui.load
+
+: file-or ( path path -- path ) over exists? ? ;
+
+: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;
+
+: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;
+
+: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;
+
+: run-ircui ( -- ) ircui-rc run-file ;
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@ -3,12 +3,17 @@

 USING: accessors kernel threads combinators concurrency.mailboxes
       sequences strings hashtables splitting fry assocs hashtables
-       ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers
-       ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs
-       io io.styles namespaces irc.client irc.messages ;
+       ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
+       ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
+       ui.gadgets.tabs ui.gadgets.grids
+       io io.styles namespaces calendar calendar.format
+       irc.client irc.client.private irc.messages irc.messages.private
+       irc.ui.commandparser irc.ui.load ;

 IN: irc.ui

+SYMBOL: listener
+
 SYMBOL: client

 TUPLE: ui-window client tabs ;
@ -19,36 +24,45 @@ TUPLE: ui-window client tabs ;
 : green { 0 0.5 0 1 } ;
 : blue { 0 0 1 1 } ;

-: prefix>nick ( prefix -- nick )
-    "!" split first ;
+: dot-or-parens ( string -- string )
+    dup empty? [ drop "." ]
+    [ "(" prepend ")" append ] if ;

 GENERIC: write-irc ( irc-message -- )

 M: privmsg write-irc
    "<" blue write-color
-    [ prefix>> prefix>nick write ] keep
+    [ prefix>> parse-name write ] keep
    "> " blue write-color
-    " " write
    trailing>> write ;

+TUPLE: own-message message nick timestamp ;
+
+: <own-message> ( message nick -- own-message )
+    now own-message boa ;
+
+M: own-message write-irc
+    "<" blue write-color
+    [ nick>> bold font-style associate format ] keep
+    "> " blue write-color
+    message>> write ;
+
 M: join write-irc
    "* " green write-color
-    prefix>> prefix>nick write
+    prefix>> parse-name write
    " has entered the channel." green write-color ;

 M: part write-irc
    "* " red write-color
-    [ prefix>> prefix>nick write ] keep
-    " has left the channel(" red write-color
-    trailing>> write
-    ")" red write-color ;
+    [ prefix>> parse-name write ] keep
+    " has left the channel" red write-color
+    trailing>> dot-or-parens red write-color ;

 M: quit write-irc
    "* " red write-color
-    [ prefix>> prefix>nick write ] keep
-    " has left IRC(" red write-color
-    trailing>> write
-    ")" red write-color ;
+    [ prefix>> parse-name write ] keep
+    " has left IRC" red write-color
+    trailing>> dot-or-parens red write-color ;

 M: irc-end write-irc
    drop "* You have left IRC" red write-color ;
@ -63,15 +77,12 @@ M: irc-message write-irc
    drop ; ! catch all unimplemented writes, THIS WILL CHANGE    

 : print-irc ( irc-message -- )
-    write-irc nl ;
+    [ timestamp>> timestamp>hms write " " write ]
+    [ write-irc nl ] bi ;

-: send-message ( message listener client -- )
-    "<" blue write-color
-    profile>> nickname>> bold font-style associate format
-    ">" blue write-color
-    " " write
-    over write nl
-    out-messages>> mailbox-put ;
+: send-message ( message -- )
+    [ print-irc ]
+    [ listener get write-message ] bi ;

 : display ( stream listener -- )
    '[ , [ [ t ]
@ -84,35 +95,44 @@ M: irc-message write-irc

 TUPLE: irc-editor < editor outstream listener client ;

-: <irc-editor> ( pane listener client -- editor )
-    [ irc-editor new-editor
+: <irc-editor> ( page pane listener -- client editor )
+    irc-editor new-editor
    swap >>listener swap <pane-stream> >>outstream
-    ] dip client>> >>client ;
+    over client>> >>client ;

 : editor-send ( irc-editor -- )
    { [ outstream>> ]
-      [ editor-string ]
      [ listener>> ]
      [ client>> ]
+      [ editor-string ]
      [ "" swap set-editor-string ] } cleave
-    '[ , , , send-message ] with-output-stream ;
+     '[ , listener set , client set , parse-message ] with-output-stream ;

 irc-editor "general" f {
    { T{ key-down f f "RET" } editor-send }
    { T{ key-down f f "ENTER" } editor-send }
 } define-command-map

-: irc-page ( name pane editor tabbed -- )
-    [ [ <scroller> @bottom frame, ! editor
-        <scroller> @center frame, ! pane
-      ] make-frame swap ] dip add-page ;
+TUPLE: irc-page < frame listener client ;
+
+: <irc-page> ( listener client -- irc-page )
+    irc-page new-frame
+    swap client>> >>client swap [ >>listener ] keep
+    [ <irc-pane> [ <scroller> @center grid-add* ] keep ]
+    [ <irc-editor> <scroller> @bottom grid-add* ] bi ;
+
+M: irc-page graft*
+    [ listener>> ] [ client>> ] bi
+    add-listener ;
+
+M: irc-page ungraft*
+    [ listener>> ] [ client>> ] bi
+    remove-listener ;

 : join-channel ( name ui-window -- )
    [ dup <irc-channel-listener> ] dip
-    [ client>> add-listener ]
-    [ drop <irc-pane> dup ]
-    [ [ <irc-editor> ] keep ] 2tri
-    tabs>> irc-page ;
+    [ <irc-page> swap ] keep
+    tabs>> add-page ;

 : irc-window ( ui-window -- )
    [ tabs>> ]
@ -125,6 +145,10 @@ irc-editor "general" f {
    [ listeners>> +server-listener+ swap at <irc-pane> <scroller>
      "Server" associate <tabbed> >>tabs ] bi ;

-: freenode-connect ( -- ui-window )
-    "irc.freenode.org" 8001 "factor-irc" f
-    <irc-profile> ui-connect [ irc-window ] keep ;
+: server-open ( server port nick password channels -- )
+    [ <irc-profile> ui-connect [ irc-window ] keep ] dip
+    [ over join-channel ] each ;
+
+: main-run ( -- ) run-ircui ;
+
+MAIN: main-run
--- a/extra/lsys/ui/ui.factor
+++ b/extra/lsys/ui/ui.factor
@ -158,7 +158,9 @@ DEFER: empty-model
 : lsys-viewer ( -- )

 [ ] <slate> >slate
-{ 400 400 } clone slate> set-slate-dim
+{ 400 400 } clone slate> set-slate-pdim
+
+slate> <handler>

 {

@ -194,13 +196,9 @@ DEFER: empty-model
 [ [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
    camera-action ] }

-! } [ make* ] map alist>hash <handler> >handler
+} [ make* ] map >hashtable >>table

-} [ make* ] map >hashtable <handler> >handler
-
-slate> handler> set-gadget-delegate
-
-handler> "L-system view" open-window
+"L-system view" open-window

 500 sleep

--- a/extra/math/primes/primes.factor
+++ b/extra/math/primes/primes.factor
@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators kernel lists.lazy math math.functions math.miller-rabin
-       math.order math.primes.list math.ranges sequences sorting ;
+       math.order math.primes.list math.ranges sequences sorting
+       binary-search ;
 IN: math.primes

 <PRIVATE
@ -13,14 +14,14 @@ PRIVATE>

 : next-prime ( n -- p )
  dup 999983 < [
-    primes-under-million [ [ <=> ] binsearch 1+ ] keep nth
+    primes-under-million [ natural-search drop 1+ ] keep nth
  ] [
    next-odd find-prime-miller-rabin
  ] if ; foldable

 : prime? ( n -- ? )
  dup 1000000 < [
-    dup primes-under-million [ <=> ] binsearch* =
+    dup primes-under-million natural-search nip =
  ] [
    miller-rabin
  ] if ; foldable
@ -37,7 +38,7 @@ PRIVATE>
  {
    { [ dup 2 < ] [ drop { } ] }
    { [ dup 1000003 < ]
-      [ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep <slice> ] }
+      [ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice> ] }
    [ primes-under-million 1000003 lprimes-from
        rot [ <= ] curry lwhile list>array append ]
  } cond ; foldable
@ -45,6 +46,6 @@ PRIVATE>
 : primes-between ( low high -- seq )
  primes-upto
  [ 1- next-prime ] dip
-  [ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
+  [ natural-search drop ] keep [ length ] keep <slice> ; foldable

 : coprime? ( a b -- ? ) gcd nip 1 = ; foldable
--- a/extra/multi-methods/tests/canonicalize.factor
+++ b/extra/multi-methods/tests/canonicalize.factor
@ -49,7 +49,7 @@ kernel strings ;
        { { object ppc object } "b" }
        { { string object windows } "c" }
    }
-    V{ cpu os }
+    { cpu os }
 ] [
    example-1 canonicalize-specializers
 ] unit-test
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@ -449,7 +449,7 @@ foo=<foreign any-char> 'd'
 ] unit-test

 [
-  "USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop
+  "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
 ] must-fail

 { t } [
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@ -371,7 +371,7 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
 M: ebnf-rule (transform) ( ast -- parser )
  dup elements>> 
  (transform) [
-    swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [ 
+    swap symbol>> dup get parser? [ 
      "Rule '" over append "' defined more than once" append throw 
    ] [ 
      set 
--- a/extra/processing/gadget/gadget.factor
+++ b/extra/processing/gadget/gadget.factor
@ -1,25 +1,14 @@

 USING: kernel namespaces combinators
-       ui.gestures qualified accessors ui.gadgets.frame-buffer ;
+       ui.gestures accessors ui.gadgets.frame-buffer ;

 IN: processing.gadget

-QUALIFIED: ui.gadgets
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-TUPLE: processing-gadget button-down button-up key-down key-up ;
+TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;

-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-gadget-delegate ( tuple gadget -- tuple )
-  over ui.gadgets:set-gadget-delegate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <processing-gadget> ( -- gadget )
-  processing-gadget new
-    <frame-buffer> set-gadget-delegate ;
+: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

--- a/extra/processing/processing.factor
+++ b/extra/processing/processing.factor
@ -374,7 +374,7 @@ SYMBOL: setup-called
  500 sleep

  <processing-gadget>
-    size-val get >>dim
+    size-val get >>pdim
    dup "Processing" open-window

    500 sleep
--- a/extra/self/slots/slots.factor
+++ b/extra/self/slots/slots.factor
@ -0,0 +1,27 @@
+
+USING: kernel words lexer parser sequences accessors self ;
+
+IN: self.slots
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: define-self-slot-reader ( slot -- )
+  [ "->" append current-vocab create dup set-word ]
+  [ ">>" append search [ self> ] swap suffix      ] bi
+  (( -- value )) define-declared ;
+
+: define-self-slot-writer ( slot -- )
+  [ "->" prepend current-vocab create dup set-word ]
+  [ ">>" prepend search [ self> swap ] swap suffix [ drop ] append ] bi
+  (( value -- )) define-declared ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: define-self-slot-accessors ( class -- )
+  "slots" word-prop
+  [ name>> ] map
+  [ [ define-self-slot-reader ] [ define-self-slot-writer ] bi ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: SELF-SLOTS: scan-word define-self-slot-accessors ; parsing
--- a/extra/soundex/soundex-tests.factor
+++ b/extra/soundex/soundex-tests.factor
@ -2,3 +2,4 @@ IN: soundex.tests
 USING: soundex tools.test ;

 [ "S162" ] [ "supercalifrag" soundex ] unit-test
+[ "M000" ] [ "M" soundex ] unit-test
--- a/extra/soundex/soundex.factor
+++ b/extra/soundex/soundex.factor
@ -25,8 +25,8 @@ TR: soundex-tr
        [ first>upper ]
        [
            soundex-tr
-            trim-first
-            remove-duplicates
+            [ "" ] [ trim-first ] if-empty
+            [ "" ] [ remove-duplicates ] if-empty
            remove-zeroes
        ] bi
        pad-4
--- a/extra/springies/ui/ui.factor
+++ b/extra/springies/ui/ui.factor
@ -51,7 +51,7 @@ DEFER: maybe-loop
 : springies-window* ( -- )

  C[ display ] <slate> >slate
-    { 800 600 }                                      slate> set-slate-dim
+    { 800 600 }                                      slate> set-slate-pdim
    C[ { 500 500 } >world-size loop on [ run ] in-thread ]
      slate> set-slate-graft
    C[ loop off ]                                    slate> set-slate-ungraft
--- a/extra/tools/vocabs/browser/browser.factor
+++ b/extra/tools/vocabs/browser/browser.factor
@ -3,7 +3,7 @@
 USING: accessors kernel combinators vocabs vocabs.loader
 tools.vocabs io io.files io.styles help.markup help.stylesheet
 sequences assocs help.topics namespaces prettyprint words
-sorting definitions arrays summary sets ;
+sorting definitions arrays summary sets generic ;
 IN: tools.vocabs.browser

 : vocab-status-string ( vocab -- string )
@ -104,9 +104,9 @@ C: <vocab-author> vocab-author
    ] unless drop ;

 : vocab-xref ( vocab quot -- vocabs )
-    >r dup vocab-name swap words r> map
+    >r dup vocab-name swap words [ generic? not ] filter r> map
    [ [ word? ] filter [ vocabulary>> ] map ] gather natural-sort
-    remove sift [ vocab ] map ; inline
+    remove sift ; inline

 : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;

@ -115,13 +115,13 @@ C: <vocab-author> vocab-author
 : describe-uses ( vocab -- )
    vocab-uses dup empty? [
        "Uses" $heading
-        dup $links
+        dup $vocab-links
    ] unless drop ;

 : describe-usage ( vocab -- )
    vocab-usage dup empty? [
        "Used by" $heading
-        dup $links
+        dup $vocab-links
    ] unless drop ;

 : $describe-vocab ( element -- )
--- a/extra/ui/gadgets/books/books.factor
+++ b/extra/ui/gadgets/books/books.factor
@ -7,10 +7,9 @@ TUPLE: book < gadget ;

 : hide-all ( book -- ) gadget-children [ hide-gadget ] each ;

-: current-page ( book -- gadget )
-    [ control-value ] keep nth-gadget ;
+: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;

-M: book model-changed
+M: book model-changed ( model book -- )
    nip
    dup hide-all
    dup current-page show-gadget
@ -19,15 +18,13 @@ M: book model-changed
 : new-book ( pages model class -- book )
  new-gadget
    swap >>model
-        [ swap add-gadgets drop ] keep ; inline
+    swap add-gadgets ; inline

-: <book> ( pages model -- book )
-    book new-book ;
+: <book> ( pages model -- book ) book new-book ;

-M: book pref-dim* gadget-children pref-dims max-dim ;
+M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;

-M: book layout*
-    dup rect-dim swap gadget-children
-    [ set-layout-dim ] with each ;
+M: book layout* ( book -- )
+   [ dim>> ] [ children>> ] bi [ set-layout-dim ] with each ;

-M: book focusable-child* current-page ;
+M: book focusable-child* ( book -- child/t ) current-page ;
--- a/extra/ui/gadgets/frame-buffer/frame-buffer.factor
+++ b/extra/ui/gadgets/frame-buffer/frame-buffer.factor
@ -7,7 +7,7 @@ IN: ui.gadgets.frame-buffer

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
+TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

@ -18,13 +18,15 @@ TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-: <frame-buffer> ( -- frame-buffer )
-  frame-buffer construct-gadget
+: new-frame-buffer ( class -- gadget )
+  new-gadget
    [ ]         >>action
-    { 100 100 } >>dim
+    { 100 100 } >>pdim
    [ ]         >>graft
    [ ]         >>ungraft ;

+: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 : draw-pixels ( fb -- fb )
@ -44,7 +46,7 @@ TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-M: frame-buffer pref-dim* dim>> ;
+M: frame-buffer pref-dim* pdim>> ;
 M: frame-buffer graft*    graft>>   call ;
 M: frame-buffer ungraft*  ungraft>> call ;

--- a/extra/ui/gadgets/frames/frames-docs.factor
+++ b/extra/ui/gadgets/frames/frames-docs.factor
@ -7,9 +7,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
 { $subsection frame }
 "Creating empty frames:"
 { $subsection <frame> }
-"Creating new frames using a combinator:"
-{ $subsection frame, }
-"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
+"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add* } ":"
 { $subsection @center }
 { $subsection @left }
 { $subsection @right }
@ -22,7 +20,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"

 : $ui-frame-constant ( element -- )
    drop
-    { $description "Symbolic constant for a common input to " { $link grid-add } " and " { $link frame, } "." } print-element ;
+    { $description "Symbolic constant for a common input to " { $link grid-add* } "." } print-element ;

 HELP: @center $ui-frame-constant ;
 HELP: @left $ui-frame-constant ;
@ -37,16 +35,12 @@ HELP: @bottom-right $ui-frame-constant ;
 HELP: frame
 { $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
 $nl
-"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
+"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add* } " and " { $link grid-remove } "." } ;

 HELP: <frame>
 { $values { "frame" frame } }
 { $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;

-HELP: frame,
-{ $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } }
-{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to make-frame." } ;
-
 { grid frame } related-words

 ABOUT: "ui-frame-layout"
--- a/extra/ui/gadgets/frames/frames.factor
+++ b/extra/ui/gadgets/frames/frames.factor
@ -38,6 +38,3 @@ M: frame layout*
    dup compute-grid
    [ rot rect-dim fill-center ] 3keep
    grid-layout ;
-
-: frame, ( gadget i j -- )
-    gadget get -rot grid-add ;
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays hashtables kernel models math namespaces
-       sequences quotations math.vectors combinators sorting vectors
-       dlists dequeues models threads concurrency.flags
-       math.order math.geometry.rect ;
+       sequences quotations math.vectors combinators sorting
+       binary-search vectors dlists dequeues models threads
+       concurrency.flags math.order math.geometry.rect ;

 IN: ui.gadgets

@ -70,12 +70,15 @@ GENERIC: children-on ( rect/point gadget -- seq )

 M: gadget children-on nip children>> ;

-: (fast-children-on) ( dim axis gadgets -- i )
-    swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
+: ((fast-children-on)) ( gadget dim axis -- <=> )
+    [ swap loc>> v- ] dip v. 0 <=> ;
+
+: (fast-children-on) ( dim axis children -- i )
+    -rot [ ((fast-children-on)) ] 2curry search drop ;

 : fast-children-on ( rect axis children -- from to )
-    [ >r >r rect-loc r> r> (fast-children-on) 0 or ]
-    [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ]
+    [ [ rect-loc ] 2dip (fast-children-on) 0 or ]
+    [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
    3bi ;

 : inside? ( bounds gadget -- ? )
@ -358,10 +361,6 @@ M: f request-focus-on 2drop ;
    [ focus>> ] follow ;

 ! Deprecated
-: set-gadget-delegate ( gadget tuple -- )
-    over [
-        dup pick [ (>>parent) ] with each-child
-    ] when set-delegate ;

 : construct-gadget ( class -- tuple )
    >r <gadget> { set-delegate } r> construct ; inline
--- a/extra/ui/gadgets/grids/grids-docs.factor
+++ b/extra/ui/gadgets/grids/grids-docs.factor
@ -7,7 +7,7 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
 "Creating grids from a fixed set of gadgets:"
 { $subsection <grid> }
 "Managing chidren:"
-{ $subsection grid-add }
+{ $subsection grid-add* }
 { $subsection grid-remove }
 { $subsection grid-child } ;

@ -18,7 +18,7 @@ $nl
 $nl
 "The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
 $nl
-"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
+"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add* } " and " { $link grid-remove } "."
 $nl
 "The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;

@ -31,7 +31,7 @@ HELP: grid-child
 { $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
 { $errors "Throws an error if the indices are out of bounds." } ;

-HELP: grid-add
+HELP: grid-add*
 { $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
 { $description "Adds a child gadget at the specified location." }
 { $side-effects "grid" } ;
--- a/extra/ui/gadgets/grids/grids.factor
+++ b/extra/ui/gadgets/grids/grids.factor
@ -20,14 +20,12 @@ grid

 : grid-child ( grid i j -- gadget ) rot grid>> nth nth ;

-: grid-add ( gadget grid i j -- )
+: grid-add* ( grid child i j -- grid )
+  >r >r dupd swap r> r>
  >r >r 2dup swap add-gadget drop r> r>
  3dup grid-child unparent rot grid>> nth set-nth ;

-: grid-add* ( grid child i j -- grid ) >r >r dupd swap r> r> grid-add ;
-
-: grid-remove ( grid i j -- )
-    >r >r >r <gadget> r> r> r> grid-add ;
+: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add* ;

 : pref-dim-grid ( grid -- dims )
    grid>> [ [ pref-dim ] map ] map ;
--- a/extra/ui/gadgets/handler/handler.factor
+++ b/extra/ui/gadgets/handler/handler.factor
@ -1,11 +1,11 @@

-USING: kernel assocs ui.gestures ;
+USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;

 IN: ui.gadgets.handler

-TUPLE: handler table ;
+TUPLE: handler < wrapper table ;

-C: <handler> handler
+: <handler> ( child -- handler ) handler new-wrapper ;

 M: handler handle-gesture* ( gadget gesture delegate -- ? )
-handler-table at dup [ call f ] [ 2drop t ] if ;
+   table>> at dup [ call f ] [ 2drop t ] if ;
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@ -10,57 +10,46 @@ sorting splitting io.streams.nested assocs
       ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
       ui.gadgets.grid-lines classes.tuple models continuations
       destructors accessors math.geometry.rect ;
+
 IN: ui.gadgets.panes

 TUPLE: pane < pack
       output current prototype scrolls?
       selection-color caret mark selecting? ;

-: clear-selection ( pane -- )
-    f >>caret
-    f >>mark
-    drop ;
+: clear-selection ( pane -- pane ) f >>caret f >>mark ;

-: add-output ( current pane -- )
-    [ set-pane-output ] [ swap add-gadget drop ] 2bi ;
+: add-output  ( pane current -- pane ) [ >>output  ] [ add-gadget ] bi ;
+: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;

-: add-current ( current pane -- )
-    [ set-pane-current ] [ swap add-gadget drop ] 2bi ;
+: prepare-line ( pane -- pane )
+  clear-selection
+  dup prototype>> clone add-current ;

-: prepare-line ( pane -- )
-    [ clear-selection ]
-    [ [ pane-prototype clone ] keep add-current ] bi ;
-
-: pane-caret&mark ( pane -- caret mark )
-    [ caret>> ] [ mark>> ] bi ;
+: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ;

 : selected-children ( pane -- seq )
    [ pane-caret&mark sort-pair ] keep gadget-subtree ;

 M: pane gadget-selection? pane-caret&mark and ;

-M: pane gadget-selection
-    selected-children gadget-text ;
+M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;

 : pane-clear ( pane -- )
-    [ clear-selection ]
+  clear-selection
  [ pane-output clear-incremental ]
  [ pane-current clear-gadget ]
-    tri ;
-
-: pane-theme ( pane -- pane )
-    selection-color >>selection-color ; inline
+  bi ;

 : new-pane ( class -- pane )
    new-gadget
        { 0 1 } >>orientation
        <shelf> >>prototype
-        <incremental> over add-output
-        dup prepare-line
-        pane-theme ;
+        <incremental> add-output
+        prepare-line
+        selection-color >>selection-color ;

-: <pane> ( -- pane )
-    pane new-pane ;
+: <pane> ( -- pane ) pane new-pane ;

 GENERIC: draw-selection ( loc obj -- )

@ -102,25 +91,25 @@ C: <pane-stream> pane-stream

 : smash-pane ( pane -- gadget ) pane-output smash-line ;

-: pane-nl ( pane -- )
+: pane-nl ( pane -- pane )
    dup pane-current dup unparent smash-line
    over pane-output add-incremental
    prepare-line ;

 : pane-write ( pane seq -- )
-    [ dup pane-nl ]
+    [ pane-nl ]
    [ over pane-current stream-write ]
    interleave drop ;

 : pane-format ( style pane seq -- )
-    [ dup pane-nl ]
+    [ pane-nl ]
    [ 2over pane-current stream-format ]
    interleave 2drop ;

 GENERIC: write-gadget ( gadget stream -- )

-M: pane-stream write-gadget
-    pane-stream-pane pane-current swap add-gadget drop ;
+M: pane-stream write-gadget ( gadget pane-stream -- )
+   pane>> current>> swap add-gadget drop ;

 M: style-stream write-gadget
    stream>> write-gadget ;
@ -148,8 +137,8 @@ M: style-stream write-gadget

 TUPLE: pane-control < pane quot ;

-M: pane-control model-changed
-    swap model-value swap dup pane-control-quot with-pane ;
+M: pane-control model-changed ( model pane-control -- )
+   [ value>> ] [ dup quot>> ] bi* with-pane ;

 : <pane-control> ( model quot -- pane )
    pane-control new-pane
@ -160,7 +149,7 @@ M: pane-control model-changed
    >r pane-stream-pane r> keep scroll-pane ; inline

 M: pane-stream stream-nl
-    [ pane-nl ] do-pane-stream ;
+    [ pane-nl drop ] do-pane-stream ;

 M: pane-stream stream-write1
    [ pane-current stream-write1 ] do-pane-stream ;
@ -337,15 +326,14 @@ M: paragraph stream-format
        2drop
    ] if ;

-: caret>mark ( pane -- )
-    dup pane-caret over set-pane-mark relayout-1 ;
+: caret>mark ( pane -- pane )
+  dup caret>> >>mark
+  dup relayout-1 ;

 GENERIC: sloppy-pick-up* ( loc gadget -- n )

-M: pack sloppy-pick-up*
-    dup gadget-orientation
-    swap gadget-children
-    (fast-children-on) ;
+M: pack sloppy-pick-up* ( loc gadget -- n )
+   [ orientation>> ] [ children>> ] bi (fast-children-on) ;

 M: gadget sloppy-pick-up*
    gadget-children [ inside? ] with find-last drop ;
@ -362,25 +350,25 @@ M: f sloppy-pick-up*
    [ 3drop { } ]
    if ;

-: move-caret ( pane -- )
+: move-caret ( pane -- pane )
  dup hand-rel
  over sloppy-pick-up
  over set-pane-caret
-    relayout-1 ;
+  dup relayout-1 ;

 : begin-selection ( pane -- )
-    dup move-caret f swap set-pane-mark ;
+    move-caret f swap set-pane-mark ;

 : extend-selection ( pane -- )
    hand-moved? [
        dup selecting?>> [
-            dup move-caret
+            move-caret
        ] [
            dup hand-clicked get child? [
                t >>selecting?
                dup hand-clicked set-global
-                dup move-caret
-                dup caret>mark
+                move-caret
+                caret>mark
            ] when
        ] if
        dup dup pane-caret gadget-at-path scroll>gadget
@ -395,8 +383,8 @@ M: f sloppy-pick-up*
    ] if ;

 : select-to-caret ( pane -- )
-    dup pane-mark [ dup caret>mark ] unless
-    dup move-caret
+    dup pane-mark [ caret>mark ] unless
+    move-caret
    dup request-focus
    com-copy-selection ;

--- a/extra/ui/gadgets/slate/slate.factor
+++ b/extra/ui/gadgets/slate/slate.factor
@ -1,122 +1,21 @@

-USING: kernel namespaces opengl ui.render ui.gadgets ;
+USING: kernel namespaces opengl ui.render ui.gadgets accessors ;

 IN: ui.gadgets.slate

-TUPLE: slate action dim graft ungraft
-       button-down
-       button-up
-       key-down
-       key-up ;
+TUPLE: slate < gadget action pdim graft ungraft ;

 : <slate> ( action -- slate )
-  slate construct-gadget
-  tuck set-slate-action
-  { 100 100 } over set-slate-dim
-  [ ] over set-slate-graft
-  [ ] over set-slate-ungraft ;
+  slate new-gadget
+    swap        >>action
+    { 100 100 } >>pdim
+    [ ]         >>graft
+    [ ]         >>ungraft ;

-M: slate pref-dim* ( slate -- dim ) slate-dim ;
+M: slate pref-dim* ( slate -- dim ) pdim>> ;

-M: slate draw-gadget* ( slate -- )
-   origin get swap slate-action with-translation ;
+M: slate draw-gadget* ( slate -- ) origin get swap action>> with-translation ;

-M: slate graft* ( slate -- ) slate-graft call ;
+M: slate graft*   ( slate -- ) graft>>   call ;
+M: slate ungraft* ( slate -- ) ungraft>> call ;

-M: slate ungraft* ( slate -- ) slate-ungraft call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: key-pressed-value
-
-: key-pressed? ( -- ? ) key-pressed-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: mouse-pressed-value
-
-: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: key-value
-
-: key ( -- key ) key-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: button-value
-
-: button ( -- val ) button-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: combinators ui.gestures accessors ;
-
-! M: slate handle-gesture* ( gadget gesture delegate -- ? )
-!    drop nip
-!    {
-!      {
-!        [ dup key-down? ]
-!        [
-       
-!          key-down-sym key-value set
-!          key-pressed-value on
-!          t
-!        ]
-!      }
-!      { [ dup key-up?   ] [ drop key-pressed-value off t ] }
-!      {
-!        [ dup button-down? ]
-!        [
-!          button-down-# mouse-button-value set
-!          mouse-pressed-value on
-!          t
-!        ]
-!      }
-!      { [ dup button-up? ] [ drop mouse-pressed-value off t ] }
-!      { [ t             ] [ drop                       t ] }
-!    }
-!    cond ;
-
-M: slate handle-gesture* ( gadget gesture delegate -- ? )
-   rot drop swap         ! delegate gesture
-   {
-     {
-       [ dup key-down? ]
-       [
-         key-down-sym key-value set
-         key-pressed-value on
-         key-down>> dup [ call ] [ drop ] if
-         t
-       ]
-     }
-     {
-       [ dup key-up?   ]
-       [
-         key-pressed-value off
-         drop
-         key-up>> dup [ call ] [ drop ] if
-         t
-       ] }
-     {
-       [ dup button-down? ]
-       [
-         button-down-# button-value set
-         mouse-pressed-value on
-         button-down>> dup [ call ] [ drop ] if
-         t
-       ]
-     }
-     {
-       [ dup button-up? ]
-       [
-         mouse-pressed-value off
-         drop
-         button-up>> dup [ call ] [ drop ] if
-         t
-       ]
-     }
-     { [ t ] [ 2drop t ] }
-   }
-   cond ;
--- a/extra/ui/gadgets/sliders/sliders.factor
+++ b/extra/ui/gadgets/sliders/sliders.factor
@ -9,26 +9,20 @@ IN: ui.gadgets.sliders

 TUPLE: elevator < gadget direction ;

-: find-elevator ( gadget -- elevator/f )
-    [ elevator? ] find-parent ;
+: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;

 TUPLE: slider < frame elevator thumb saved line ;

-: find-slider ( gadget -- slider/f )
-    [ slider? ] find-parent ;
+: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;

 : elevator-length ( slider -- n )
-    dup slider-elevator rect-dim
-    swap gadget-orientation v. ;
+  [ elevator>> dim>> ] [ orientation>> ] bi v. ;

 : min-thumb-dim 15 ;

 : slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
-
 : slider-page  ( gadget -- n ) gadget-model range-page-value    ;
-
 : slider-max   ( gadget -- n ) gadget-model range-max-value     ;
-
 : slider-max*  ( gadget -- n ) gadget-model range-max-value*    ;

 : thumb-dim ( slider -- h )
@ -45,7 +39,6 @@ TUPLE: slider < frame elevator thumb saved line ;
    swap slider-max* 1 max / ;

 : slider>screen ( m scale -- n ) slider-scale * ;
-
 : screen>slider ( m scale -- n ) slider-scale / ;

 M: slider model-changed nip slider-elevator relayout-1 ;
@ -76,11 +69,9 @@ thumb H{
        t >>root?
    thumb-theme ;

-: slide-by ( amount slider -- )
-    gadget-model move-by ;
+: slide-by ( amount slider -- ) gadget-model move-by ;

-: slide-by-page ( amount slider -- )
-    gadget-model move-by-page ;
+: slide-by-page ( amount slider -- ) gadget-model move-by-page ;

 : compute-direction ( elevator -- -1/1 )
    dup find-slider swap hand-click-rel
@ -100,13 +91,10 @@ elevator H{
    { T{ button-down } [ elevator-click ] }
 } set-gestures

-: elevator-theme ( elevator -- )
-    lowered-gradient swap set-gadget-interior ;
-
 : <elevator> ( vector -- elevator )
  elevator new-gadget
-    [ set-gadget-orientation ] keep
-    dup elevator-theme ;
+    swap             >>orientation
+    lowered-gradient >>interior ;

 : (layout-thumb) ( slider n -- n thumb )
    over gadget-orientation n*v swap slider-thumb ;
@ -144,17 +132,10 @@ M: elevator layout*
  dup elevator>> over thumb>> add-gadget
  @center grid-add* ;

-: <left-button> ( -- button )
-    { 0 1 } arrow-left -1 <slide-button> ;
-
-: <right-button> ( -- button )
-    { 0 1 } arrow-right 1 <slide-button> ;
-
-: <up-button> ( -- button )
-    { 1 0 } arrow-up -1 <slide-button> ;
-
-: <down-button> ( -- button )
-    { 1 0 } arrow-down 1 <slide-button> ;
+: <left-button>  ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
+: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
+: <up-button>    ( -- button ) { 1 0 } arrow-up   -1 <slide-button> ;
+: <down-button>  ( -- button ) { 1 0 } arrow-down  1 <slide-button> ;

 : <slider> ( range orientation -- slider )
    slider new-frame
--- a/extra/ui/gadgets/slots/slots.factor
+++ b/extra/ui/gadgets/slots/slots.factor
@ -109,7 +109,7 @@ TUPLE: editable-slot < track printer ref ;
    [ clear-track ]
    [
        dup ref>> <slot-editor>
-        [ swap 1 track-add ]
+        [ 1 track-add* drop ]
        [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
    ] bi ;

--- a/extra/ui/gadgets/status-bar/status-bar.factor
+++ b/extra/ui/gadgets/status-bar/status-bar.factor
@ -12,7 +12,7 @@ IN: ui.gadgets.status-bar

 : open-status-window ( gadget title -- )
    f <model> [ <world> ] keep
-    <status-bar> over f track-add
+    <status-bar> f track-add*
    open-world-window ;

 : show-summary ( object gadget -- )
--- a/extra/ui/gadgets/tracks/tracks-docs.factor
+++ b/extra/ui/gadgets/tracks/tracks-docs.factor
@ -8,7 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
 "Creating empty tracks:"
 { $subsection <track> }
 "Adding children:"
-{ $subsection track-add } ;
+{ $subsection track-add* } ;

 HELP: track
 { $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
@ -17,7 +17,7 @@ HELP: <track>
 { $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
 { $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ; 

-HELP: track-add
+HELP: track-add*
 { $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
 { $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;

--- a/extra/ui/gadgets/tracks/tracks.factor
+++ b/extra/ui/gadgets/tracks/tracks.factor
@ -41,14 +41,11 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;

 M: track pref-dim* ( gadget -- dim )
   [ track-pref-dims-1                           ]
-   [ [ alloted-dim ] [ track-pref-dims-1 ] bi v+ ]
+   [ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
   [ orientation>>                               ]
   tri
   set-axis ;

-: track-add ( gadget track constraint -- )
-    over track-sizes push swap add-gadget drop ;
-
 : track-add* ( track gadget constraint -- track )
  pick sizes>> push add-gadget ;

--- a/extra/ui/gadgets/worlds/worlds.factor
+++ b/extra/ui/gadgets/worlds/worlds.factor
@ -40,7 +40,7 @@ M: world request-focus-on ( child gadget -- )
        { 0 0 } >>window-loc
        swap >>status
        swap >>title
-        [ 1 track-add ] keep
+        swap 1 track-add*
    dup request-focus ;

 M: world layout*
--- a/extra/ui/gadgets/wrappers/wrappers.factor
+++ b/extra/ui/gadgets/wrappers/wrappers.factor
@ -1,22 +1,18 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors ui.gadgets kernel ;
+
 IN: ui.gadgets.wrappers

 TUPLE: wrapper < gadget ;

-: new-wrapper ( child class -- wrapper )
-    new-gadget
-        [ swap add-gadget drop ] keep ; inline
+: new-wrapper ( child class -- wrapper ) new-gadget swap add-gadget ;

-: <wrapper> ( child -- border )
-    wrapper new-wrapper ;
+: <wrapper> ( child -- border ) wrapper new-wrapper ;

-M: wrapper pref-dim*
-    gadget-child pref-dim ;
+M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;

-M: wrapper layout*
+M: wrapper layout* ( wrapper -- )
    [ dim>> ] [ gadget-child ] bi set-layout-dim ;

-M: wrapper focusable-child*
-    gadget-child ;
+M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;
--- a/extra/ui/tools/workspace/workspace.factor
+++ b/extra/ui/tools/workspace/workspace.factor
@ -61,8 +61,8 @@ M: gadget tool-scroller drop f ;

 : show-popup ( gadget workspace -- )
  dup hide-popup
-    2dup set-workspace-popup
-    dupd f track-add
+  over >>popup
+  over f track-add* drop
  request-focus ;

 : show-titled-popup ( workspace gadget title -- )
--- a/extra/usa-cities/usa-cities.factor
+++ b/extra/usa-cities/usa-cities.factor
@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files io.encodings.ascii sequences generalizations
 math.parser combinators kernel memoize csv symbols summary
-words accessors math.order sorting ;
+words accessors math.order binary-search ;
 IN: usa-cities

 SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN
@ -50,4 +50,4 @@ MEMO: cities-named-in ( name state -- cities )
    ] with with filter ;

 : find-zip-code ( code -- city )
-    cities [ first-zip>> <=> ] binsearch* ;
+    cities [ first-zip>> <=> ] with search nip ;