diff --git a/core/binary-search/binary-search-docs.factor b/core/binary-search/binary-search-docs.factor new file mode 100644 index 0000000000..db442a9ac8 --- /dev/null +++ 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 diff --git a/core/binary-search/binary-search-tests.factor b/core/binary-search/binary-search-tests.factor new file mode 100644 index 0000000000..77b1c16505 --- /dev/null +++ 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 diff --git a/core/binary-search/binary-search.factor b/core/binary-search/binary-search.factor new file mode 100644 index 0000000000..87a4e0f503 --- /dev/null +++ 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 + + ) + [ 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 (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? ; diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 3b1a5c6c85..1085feb0c6 100755 --- 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 diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index cd5ec7fda2..af35607ce9 100755 --- 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 ] } diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index ab808d7914..1e659f1b99 100755 --- 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 ] [ diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 1bb7666447..8434a99b30 100755 --- 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 } "." } ; diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index d52ea5e11f..18bc7f14cf 100644 --- 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 diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index 17ec2d7cd1..63e193c89f 100755 --- 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 diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 1a2491328c..8b84ea8fe0 100755 --- 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 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 - ] [ - over empty? [ - 2drop 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@ ] [ - 3dup smallest r> [ push ] keep (merge) + dup 3 = [ + 2drop dup 1+ dup 1+ + r> [ nth-unsafe ] curry tri@ + r> [ push ] curry tri@ + ] [ + drop r> subseq r> push-all + ] if ] if ] if ; inline -: merge ( sorted1 sorted2 quot -- result ) - >r [ [ ] bi@ ] 2keep r> - rot length rot length + - [ (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 + +: ( seq -- merge ) + \ merge new + over >vector >>accum1 + swap length >>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' ) + [ ] 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 ] [ (binsearch) ] if ; inline - -: binsearch* ( elt seq quot -- result ) - over >r binsearch [ r> ?nth ] [ r> drop f ] if* ; inline diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index 78f1074eb8..8dd3c7ece5 100644 --- 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 ] - { 400 400 } >>dim + { 400 400 } >>pdim dup >slate - @center grid-add + @center grid-add* + + 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 - - - tuck set-gadget-delegate + >>table "Automata" open-window ; diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor new file mode 100644 index 0000000000..0ffaaa4867 --- /dev/null +++ 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 ] [ [ 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 diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index f45b1cc0ff..6d57bb32ac 100755 --- 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 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* + + 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 - tuck set-gadget-delegate "Boids" open-window ; + + >>table + + "Boids" open-window ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 63fd55a550..2dfa7fae8f 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -204,7 +204,7 @@ VAR: start-shape : cfdg-window* ( -- ) [ display ] closed-quot - { 500 500 } over set-slate-dim + { 500 500 } over set-slate-pdim dup "CFDG" open-window ; : cfdg-window ( -- ) [ cfdg-window* ] with-ui ; \ No newline at end of file diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index df72572c67..3300faa125 100755 --- 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 [ 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 [ 4 swap to ] in-thread [ 2 swap to ] in-thread diff --git a/extra/cords/cords.factor b/extra/cords/cords.factor index a7f4246826..52cb9914b4 100644 --- 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 > ; M: multi-cord virtual@ dupd - seqs>> [ first <=> ] binsearch* + seqs>> [ first <=> ] with search nip [ first - ] [ second ] bi ; M: multi-cord virtual-seq diff --git a/extra/display-stack/display-stack.factor b/extra/display-stack/display-stack.factor new file mode 100644 index 0000000000..8da252f294 --- /dev/null +++ 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 ; + diff --git a/extra/farkup/authors.factor b/extra/farkup/authors.factor deleted file mode 100644 index 5674120196..0000000000 --- a/extra/farkup/authors.factor +++ /dev/null @@ -1,2 +0,0 @@ -Doug Coleman -Slava Pestov diff --git a/extra/farkup/authors.txt b/extra/farkup/authors.txt index 7c1b2f2279..5674120196 100644 --- a/extra/farkup/authors.txt +++ b/extra/farkup/authors.txt @@ -1 +1,2 @@ Doug Coleman +Slava Pestov diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor old mode 100755 new mode 100644 index 17d286252e..005e875d89 --- 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 -[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test -[ "
  • foo
\n" ] [ "-foo\n" convert-farkup ] unit-test -[ "
  • foo
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test -[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test +[ ] [ + "abcd-*strong*\nasdifj\nweouh23ouh23" + "paragraph" \ farkup rule parse drop +] unit-test -[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test +[ ] [ + "abcd-*strong*\nasdifj\nweouh23ouh23\n" + "paragraph" \ farkup rule parse drop +] unit-test + +[ "

a-b

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

*foo\nbar\n

" ] [ "*foo\nbar\n" convert-farkup ] unit-test [ "

Wow!

" ] [ "*Wow!*" convert-farkup ] unit-test [ "

Wow.

" ] [ "_Wow._" convert-farkup ] unit-test @@ -15,11 +22,20 @@ IN: farkup.tests [ "

*

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

**

" ] [ "\\**" 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 +[ "
  • a-b
" ] [ "-a-b" convert-farkup ] unit-test +[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test +[ "
  • foo
    • \n
" ] [ "-foo\n" convert-farkup ] unit-test +[ "
  • foo
    • \n
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test +[ "
  • foo
    • \n
  • bar
    • \n
" ] [ "-foo\n-bar\n" convert-farkup ] unit-test + +[ "
  • foo
    • \n

bar\n

" ] [ "-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 [ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test [ "

foo

bar

" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test [ "

foo

bar

" ] [ "foo\r\rbar" convert-farkup ] unit-test @@ -29,7 +45,7 @@ IN: farkup.tests [ "\n

bar\n

" ] [ "\rbar\r" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\r\nbar\r\n" convert-farkup ] unit-test -[ "

foo

\n

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "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 [ - "

Feature comparison:\n\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" + "

Feature comparison:

aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes
" ] [ "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 - -[ "

a-b

" ] [ "a-b" convert-farkup ] unit-test -[ "
  • a-b
" ] [ "-a-b" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor old mode 100755 new mode 100644 index 321648136a..baf2ccaba2 --- 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? - [[ 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 swap 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> - [ - 
-            htmlize-lines
-
- ] 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 - [ - "r , r> "\"" , - link-no-follow? get [ " nofollow=\"true\"" , ] when - ">" , , "" , - ] { } make ; + "" write write "" write ; -: make-image-link ( href alt -- seq ) +: write-image-link ( href text -- ) disable-images? get [ - 2drop "Images are not allowed" + 2drop "Images are not allowed" write ] [ escape-link - [ - "\""" , - ] { } make + >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 ; + 
+            htmlize-lines
+
+ ] 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? - [ "

" swap "

" 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 -- ) +: ( string -- ) write ; +: ( string -- ) write ; +: in-tag. ( obj quot string -- ) [ call ] keep ; 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 ; diff --git a/extra/golden-section/golden-section.factor b/extra/golden-section/golden-section.factor index ef6f1ca4c2..8ae8bccc25 100644 --- 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 ; + opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme + ui.gadgets.slate colors accessors combinators.cleave ; + IN: golden-section ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! To run: -! "golden-section" run +: disk ( radius center -- ) + glPushMatrix + gl-translate + dup 0 glScalef + gluNewQuadric [ 0 1 20 20 gluDisk ] [ gluDeleteQuadric ] bi + glPopMatrix ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: disk ( quadric radius center -- ) - glPushMatrix - gl-translate - dup 0 glScalef - 0 1 10 10 gluDisk - 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 ; + GL_PROJECTION glMatrixMode + glLoadIdentity + -400 400 -400 400 -1 1 glOrtho + GL_MODELVIEW glMatrixMode + glLoadIdentity + golden-section ; : golden-section-window ( -- ) [ - [ display ] - { 600 600 } over set-slate-dim - "Golden Section" open-window - ] with-ui ; + [ display ] + { 600 600 } >>pdim + "Golden Section" open-window + ] + with-ui ; MAIN: golden-section-window diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 692255bdd5..0f2de467f9 100755 --- 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 ; diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 5779371078..56c7118ab9 100644 --- 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 -[ "
  • foo
  • bar
" ] [ +[ "
  • foo
    • \n
  • bar
" ] [ [ "farkup" T{ farkup } render ] with-string-writer ] unit-test diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor index 95e3794e32..a62855d78f 100755 --- 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 ; ] binsearch* ; + [ first <=> ] with search nip ; : interval-contains? ( key interval-node -- ? ) first2 between? ; diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 472805f5ae..2dbbe8b8f5 100644 --- 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+ irc-server-listener boa ; : ( name -- irc-channel-listener ) - rot f 60 seconds irc-channel-listener boa ; + [ ] dip f 60 seconds H{ } clone irc-channel-listener boa ; : ( name -- irc-nick-listener ) - rot irc-nick-listener boa ; + [ ] 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> diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index f1beba9b26..205630d790 100644 --- 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" ; + > nickname>> print-irc ] + [ listener get write-message ] bi ; + +: quote ( string -- ) + drop ; ! THIS WILL CHANGE diff --git a/extra/irc/ui/ircui-rc b/extra/irc/ui/ircui-rc new file mode 100755 index 0000000000..a1533c7b4d --- /dev/null +++ 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 diff --git a/extra/irc/ui/load/load.factor b/extra/irc/ui/load/load.factor new file mode 100755 index 0000000000..6655f310e7 --- /dev/null +++ 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 ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index cc138dad92..12f9d01183 100755 --- 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 - ">" blue write-color - " " write + [ prefix>> parse-name write ] keep + "> " blue write-color trailing>> write ; +TUPLE: own-message message nick timestamp ; + +: ( 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 ; -: ( pane listener client -- editor ) - [ irc-editor new-editor +: ( page pane listener -- client editor ) + irc-editor new-editor swap >>listener swap >>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 -- ) - [ [ @bottom frame, ! editor - @center frame, ! pane - ] make-frame swap ] dip add-page ; +TUPLE: irc-page < frame listener client ; + +: ( listener client -- irc-page ) + irc-page new-frame + swap client>> >>client swap [ >>listener ] keep + [ [ @center grid-add* ] keep ] + [ @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 ] dip - [ client>> add-listener ] - [ drop dup ] - [ [ ] keep ] 2tri - tabs>> 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 "Server" associate >>tabs ] bi ; -: freenode-connect ( -- ui-window ) - "irc.freenode.org" 8001 "factor-irc" f - ui-connect [ irc-window ] keep ; +: server-open ( server port nick password channels -- ) + [ ui-connect [ irc-window ] keep ] dip + [ over join-channel ] each ; + +: main-run ( -- ) run-ircui ; + +MAIN: main-run diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor index f7ec181f61..420d5a3f4c 100644 --- a/extra/lsys/ui/ui.factor +++ b/extra/lsys/ui/ui.factor @@ -158,7 +158,9 @@ DEFER: empty-model : lsys-viewer ( -- ) [ ] >slate -{ 400 400 } clone slate> set-slate-dim +{ 400 400 } clone slate> set-slate-pdim + +slate> { @@ -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 +} [ make* ] map >hashtable >>table -} [ make* ] map >hashtable >handler - -slate> handler> set-gadget-delegate - -handler> "L-system view" open-window +"L-system view" open-window 500 sleep diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index 59aebbf0dd..f3a515e72b 100644 --- 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 : 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 ] } + [ primes-under-million [ natural-search drop 1+ 0 swap ] keep ] } [ 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 ; foldable + [ natural-search drop ] keep [ length ] keep ; foldable : coprime? ( a b -- ? ) gcd nip 1 = ; foldable diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor index d5baf4914c..991551c009 100644 --- 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 diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 7f14293a15..45e1e9b218 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -449,7 +449,7 @@ foo= 'd' ] unit-test [ - "USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop + "USING: peg.ebnf ; " eval drop ] must-fail { t } [ @@ -519,4 +519,4 @@ Tok = Spaces (Number | Special ) { "\\" } [ "\\" [EBNF foo="\\" EBNF] -] unit-test \ No newline at end of file +] unit-test diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 2a75fcccc0..cc94a215e6 100644 --- 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 diff --git a/extra/processing/gadget/gadget.factor b/extra/processing/gadget/gadget.factor index bac3f8ac6d..4621bab855 100644 --- 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: ( -- gadget ) - processing-gadget new - set-gadget-delegate ; +: ( -- gadget ) processing-gadget new-frame-buffer ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor old mode 100755 new mode 100644 index 4c9dd787e5..f786628c79 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -374,7 +374,7 @@ SYMBOL: setup-called 500 sleep - size-val get >>dim + size-val get >>pdim dup "Processing" open-window 500 sleep diff --git a/extra/self/slots/slots.factor b/extra/self/slots/slots.factor new file mode 100644 index 0000000000..b07641a062 --- /dev/null +++ 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 \ No newline at end of file diff --git a/extra/soundex/soundex-tests.factor b/extra/soundex/soundex-tests.factor index df6338c4ec..f4bd18e34b 100644 --- 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 diff --git a/extra/soundex/soundex.factor b/extra/soundex/soundex.factor index c82825d814..23d5ee4d4c 100644 --- 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 diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor index 365632e974..f2248ba6f2 100644 --- a/extra/springies/ui/ui.factor +++ b/extra/springies/ui/ui.factor @@ -51,7 +51,7 @@ DEFER: maybe-loop : springies-window* ( -- ) C[ display ] >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 diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index afbb936df1..55a96c8b7d 100755 --- 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 ] 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 : 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 -- ) diff --git a/extra/ui/gadgets/books/books.factor b/extra/ui/gadgets/books/books.factor index ce15bd9e6c..9f92266efe 100755 --- a/extra/ui/gadgets/books/books.factor +++ b/extra/ui/gadgets/books/books.factor @@ -7,27 +7,24 @@ 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 relayout ; : new-book ( pages model class -- book ) - new-gadget - swap >>model - [ swap add-gadgets drop ] keep ; inline + new-gadget + swap >>model + swap add-gadgets ; inline -: ( pages model -- book ) - book new-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 ; diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor index 7d77db24cc..2d58037982 100644 --- 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 construct-gadget +: new-frame-buffer ( class -- gadget ) + new-gadget [ ] >>action - { 100 100 } >>dim + { 100 100 } >>pdim [ ] >>graft [ ] >>ungraft ; +: ( -- 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 ; diff --git a/extra/ui/gadgets/frames/frames-docs.factor b/extra/ui/gadgets/frames/frames-docs.factor index db3ae856b1..890836dcaa 100755 --- 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 } -"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 } " 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 } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add* } " and " { $link grid-remove } "." } ; HELP: { $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" diff --git a/extra/ui/gadgets/frames/frames.factor b/extra/ui/gadgets/frames/frames.factor index 4e0601d4c3..c210d1b7e2 100644 --- 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 ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 19593d2f22..0c2caebb3d 100755 --- 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 { set-delegate } r> construct ; inline diff --git a/extra/ui/gadgets/grids/grids-docs.factor b/extra/ui/gadgets/grids/grids-docs.factor index eb7affdb80..31f85e4784 100755 --- 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 } "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 } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "." +"Grids are created by calling " { $link } " 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" } ; diff --git a/extra/ui/gadgets/grids/grids.factor b/extra/ui/gadgets/grids/grids.factor index f934ae5fa6..b53bf063f2 100644 --- 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 -- ) - >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> + >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 r> r> r> grid-add ; +: grid-remove ( grid i j -- grid ) -rot grid-add* ; : pref-dim-grid ( grid -- dims ) grid>> [ [ pref-dim ] map ] map ; diff --git a/extra/ui/gadgets/handler/handler.factor b/extra/ui/gadgets/handler/handler.factor index da33660a8d..bff03c7d9f 100644 --- 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 +: ( child -- handler ) handler new-wrapper ; M: handler handle-gesture* ( gadget gesture delegate -- ? ) -handler-table at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file + table>> at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 9b547ce544..cca757e0eb 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -1,66 +1,55 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons -ui.gadgets.labels ui.gadgets.scrollers -ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs -ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render -hashtables io kernel namespaces sequences io.styles strings -quotations math opengl combinators math.vectors -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 ; + ui.gadgets.labels ui.gadgets.scrollers + ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs + ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render + hashtables io kernel namespaces sequences io.styles strings + quotations math opengl combinators math.vectors + 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? ; + 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 ] - [ pane-output clear-incremental ] - [ pane-current clear-gadget ] - tri ; - -: pane-theme ( pane -- pane ) - selection-color >>selection-color ; inline + clear-selection + [ pane-output clear-incremental ] + [ pane-current clear-gadget ] + bi ; : new-pane ( class -- pane ) new-gadget { 0 1 } >>orientation >>prototype - over add-output - dup prepare-line - pane-theme ; + add-output + prepare-line + selection-color >>selection-color ; -: ( -- pane ) - pane new-pane ; +: ( -- pane ) pane new-pane ; GENERIC: draw-selection ( loc obj -- ) @@ -102,25 +91,25 @@ C: 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 ; : ( 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 -- ) - dup hand-rel - over sloppy-pick-up - over set-pane-caret - relayout-1 ; +: move-caret ( pane -- pane ) + dup hand-rel + over sloppy-pick-up + over set-pane-caret + 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 ; diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor index ab2abeec5b..2ef740e580 100644 --- 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 ; : ( 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 ; \ No newline at end of file diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor index 7904a9ab66..4e081d972f 100755 --- a/extra/ui/gadgets/sliders/sliders.factor +++ b/extra/ui/gadgets/sliders/sliders.factor @@ -9,27 +9,21 @@ 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* ; +: 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 ) dup slider-page over slider-max 1 max / 1 min @@ -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 ; - : ( vector -- elevator ) - elevator new-gadget - [ set-gadget-orientation ] keep - dup elevator-theme ; + elevator new-gadget + 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* ; -: ( -- button ) - { 0 1 } arrow-left -1 ; - -: ( -- button ) - { 0 1 } arrow-right 1 ; - -: ( -- button ) - { 1 0 } arrow-up -1 ; - -: ( -- button ) - { 1 0 } arrow-down 1 ; +: ( -- button ) { 0 1 } arrow-left -1 ; +: ( -- button ) { 0 1 } arrow-right 1 ; +: ( -- button ) { 1 0 } arrow-up -1 ; +: ( -- button ) { 1 0 } arrow-down 1 ; : ( range orientation -- slider ) slider new-frame diff --git a/extra/ui/gadgets/slots/slots.factor b/extra/ui/gadgets/slots/slots.factor index cd339d7ff7..2ce4a1fa8c 100755 --- 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>> - [ swap 1 track-add ] + [ 1 track-add* drop ] [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi ] bi ; diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/extra/ui/gadgets/status-bar/status-bar.factor index 6ffc311dcb..9c709c2f78 100755 --- 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 [ ] keep - over f track-add + f track-add* open-world-window ; : show-summary ( object gadget -- ) diff --git a/extra/ui/gadgets/tracks/tracks-docs.factor b/extra/ui/gadgets/tracks/tracks-docs.factor index 7fbbd1a330..2c2ebac15d 100755 --- 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 } "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 } "." } ; @@ -17,7 +17,7 @@ HELP: { $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." } ; diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor index bf6b02463e..4e8a650116 100644 --- 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 ; diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor index dc4debd900..0e7fbb4c30 100755 --- 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* diff --git a/extra/ui/gadgets/wrappers/wrappers.factor b/extra/ui/gadgets/wrappers/wrappers.factor index 55846b2255..447704f818 100644 --- 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 ; -: ( child -- border ) - wrapper new-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 ; diff --git a/extra/ui/tools/workspace/workspace.factor b/extra/ui/tools/workspace/workspace.factor index 45dfd32609..86cfdb02c7 100755 --- a/extra/ui/tools/workspace/workspace.factor +++ b/extra/ui/tools/workspace/workspace.factor @@ -60,10 +60,10 @@ M: gadget tool-scroller drop f ; request-focus ; : show-popup ( gadget workspace -- ) - dup hide-popup - 2dup set-workspace-popup - dupd f track-add - request-focus ; + dup hide-popup + over >>popup + over f track-add* drop + request-focus ; : show-titled-popup ( workspace gadget title -- ) [ find-workspace hide-popup ] diff --git a/extra/usa-cities/usa-cities.factor b/extra/usa-cities/usa-cities.factor index 968bf9d053..c5e059c519 100644 --- 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 ;