--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.private accessors math
+math.order combinators ;
+IN: binary-search
+
+<PRIVATE
+
+: midpoint ( seq -- elt )
+ [ midpoint@ ] keep nth-unsafe ; inline
+
+: decide ( quot seq -- quot seq <=> )
+ [ midpoint swap call ] 2keep rot ; inline
+
+: finish ( quot slice -- i elt )
+ [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
+ [ drop ] [ dup ] [ ] tri* nth ; inline
+
+: (search) ( quot seq -- i elt )
+ dup length 1 <= [
+ finish
+ ] [
+ decide {
+ { +eq+ [ finish ] }
+ { +lt+ [ dup midpoint@ head-slice (search) ] }
+ { +gt+ [ dup midpoint@ tail-slice (search) ] }
+ } case
+ ] if ; inline
+
+PRIVATE>
+
+: search ( seq quot -- i elt )
+ over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ;
+ inline
+
+: natural-search ( obj seq -- i elt )
+ [ <=> ] with search ;
+
+: sorted-index ( obj seq -- i )
+ natural-search drop ;
+
+: sorted-member? ( obj seq -- ? )
+ dupd natural-search nip = ;
+
+: sorted-memq? ( obj seq -- ? )
+ dupd natural-search nip eq? ;
\ + 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
{ [ 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 ] }
! Regression
USE: sorting
-USE: sorting.private
+USE: binary-search.private
: old-binsearch ( elt quot seq -- elt quot i )
dup length 1 <= [
] [
[ 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 ] [
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
+{ $subsection "binary-search" }
{ $subsection "sets" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
{ $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 } "." } ;
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"
{ $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
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 ]
[ 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
-! 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
-<PRIVATE
-
-: <iterator> 0 tail-slice ; inline
-
-: this ( slice -- obj )
- dup slice-from swap slice-seq nth-unsafe ; inline
+! 2) first phase (interchanging pairs x[i], x[i+1] where
+! x[i] > x[i+1]) is handled specially
-: 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
+<PRIVATE
-: (merge) ( iter1 iter2 quot accum -- )
- >r pick empty? [
- drop nip r> push-all
- ] [
- over empty? [
- 2drop r> push-all
+TUPLE: merge
+{ seq array }
+{ accum vector }
+{ accum1 vector }
+{ accum2 vector }
+{ from1 array-capacity }
+{ to1 array-capacity }
+{ from2 array-capacity }
+{ to2 array-capacity } ;
+
+: 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 [ [ <iterator> ] bi@ ] 2keep r>
- rot length rot length + <vector>
- [ (merge) ] [ underlying>> ] bi ; inline
+: l-elt [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
+: r-elt [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
+: l-done? [ from1>> ] [ to1>> ] bi number= ; inline
+: r-done? [ from2>> ] [ to2>> ] bi number= ; inline
+: dump-l [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
+: dump-r [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
+: l-next [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
+: r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
+: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
+
+: (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
-: conquer ( first second quot -- result )
- [ tuck >r >r sort r> r> sort ] keep merge ; inline
+: flip-accum ( merge -- )
+ dup [ accum>> ] [ accum1>> ] bi eq? [
+ dup accum1>> underlying>> >>seq
+ dup accum2>> >>accum
+ ] [
+ dup accum1>> >>accum
+ dup accum2>> underlying>> >>seq
+ ] if
+ dup accum>> 0 >>length 2drop ; inline
+
+: <merge> ( seq -- merge )
+ \ merge new
+ over >vector >>accum1
+ swap length <vector> >>accum2
+ dup accum1>> underlying>> >>seq
+ dup accum2>> >>accum
+ dup accum>> 0 >>length drop ; inline
+
+: compute-midpoint ( merge -- merge )
+ dup [ from1>> ] [ to2>> ] bi + 2/ >>to1 ; inline
+
+: merging ( from to merge -- )
+ swap >>to2
+ swap >>from1
+ compute-midpoint
+ dup [ to1>> ] [ seq>> length ] bi min >>to1
+ dup [ to2>> ] [ seq>> length ] bi min >>to2
+ dup to1>> >>from2
+ drop ; inline
+
+: nth-chunk ( n size -- from to ) [ * dup ] keep + ; inline
+
+: chunks ( length size -- n ) [ align ] keep /i ; inline
+
+: each-chunk ( length size quot -- )
+ [ [ chunks ] keep ] dip
+ [ nth-chunk ] prepose curry
+ each-integer ; inline
+
+: merge ( from to merge quot -- )
+ [ [ merging ] keep ] dip (merge) ; inline
+
+: sort-pass ( merge size quot -- )
+ [
+ over flip-accum
+ over [ seq>> length ] 2dip
+ ] dip
+ [ merge ] 2curry each-chunk ; inline
+
+: sort-loop ( merge quot -- )
+ 2 swap
+ [ pick seq>> length pick > ]
+ [ [ dup ] [ 1 shift ] [ ] tri* [ sort-pass ] 2keep ]
+ [ ] while 3drop ; inline
+
+: each-pair ( seq quot -- )
+ [ [ length 1+ 2/ ] keep ] dip
+ [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
+
+: (sort-pairs) ( i1 i2 seq quot accum -- )
+ >r >r 2dup length = [
+ nip nth r> drop r> push
+ ] [
+ tuck [ nth-unsafe ] 2bi@ 2dup r> call +gt+ eq?
+ [ swap ] when r> tuck [ push ] 2bi@
+ ] if ; inline
+
+: sort-pairs ( merge quot -- )
+ [ [ seq>> ] [ accum>> ] bi ] dip swap
+ [ (sort-pairs) ] 2curry each-pair ; inline
PRIVATE>
-: sort ( seq quot -- sortedseq )
- over length 1 <=
- [ drop ] [ over >r >r halves r> conquer r> like ] if ;
+: sort ( seq quot -- seq' )
+ [ <merge> ] dip
+ [ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ;
inline
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
: sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
-
-: midpoint ( seq -- elt )
- [ midpoint@ ] keep nth-unsafe ; inline
-
-: partition ( seq n -- slice )
- +gt+ eq? not swap halves ? ; inline
-
-: (binsearch) ( elt quot seq -- i )
- dup length 1 <= [
- slice-from 2nip
- ] [
- [ midpoint swap call ] 3keep roll dup +eq+ eq?
- [ drop dup slice-from swap midpoint@ + 2nip ]
- [ partition (binsearch) ] if
- ] if ; inline
-
-: binsearch ( elt seq quot -- i )
- swap dup empty?
- [ 3drop f ] [ <flat-slice> (binsearch) ] if ; inline
-
-: binsearch* ( elt seq quot -- result )
- over >r binsearch [ r> ?nth ] [ r> drop f ] if* ; inline
ui
ui.gestures
ui.gadgets
- ui.gadgets.handler
ui.gadgets.slate
ui.gadgets.labels
ui.gadgets.buttons
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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-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 ;
"5 - Random Rule" [ random-rule ] view-button add-gadget
"n - New" [ automata-window ] view-button add-gadget
- @top grid-add
+ @top grid-add*
C[ display ] <slate>
- { 400 400 } >>dim
+ { 400 400 } >>pdim
dup >slate
- @center grid-add
+ @center grid-add*
+
+ <handler>
H{ }
T{ key-down f f "1" } [ start-center ] view-action is
T{ key-down f f "5" } [ random-rule ] view-action is
T{ key-down f f "n" } [ automata-window ] view-action is
- <handler>
-
- tuck set-gadget-delegate
+ >>table
"Automata" open-window ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: backtrack shuffle math math.ranges quotations locals fry
+kernel words io memoize macros io prettyprint sequences assocs
+combinators namespaces ;
+IN: benchmark.backtrack
+
+! This was suggested by Dr_Ford. Compute the number of quadruples
+! (a,b,c,d) with 1 <= a,b,c,d <= 10 such that we can make 24 by
+! placing them on the stack, and applying the operations
+! +, -, * and rot as many times as we wish.
+
+: nop ;
+
+MACRO: amb-execute ( seq -- quot )
+ [ length ] [ <enum> [ 1quotation ] assoc-map ] bi
+ '[ , amb , case ] ;
+
+: if-amb ( true false -- )
+ [
+ [ { t f } amb ]
+ [ '[ @ require t ] ]
+ [ '[ @ f ] ]
+ tri* if
+ ] with-scope ; inline
+
+: do-something ( a b -- c )
+ { + - * } amb-execute ;
+
+: some-rots ( a b c -- a b c )
+ #! Try to rot 0, 1 or 2 times.
+ { nop rot -rot } amb-execute ;
+
+MEMO: 24-from-1 ( a -- ? )
+ 24 = ;
+
+MEMO: 24-from-2 ( a b -- ? )
+ [ do-something 24-from-1 ] [ 2drop ] if-amb ;
+
+MEMO: 24-from-3 ( a b c -- ? )
+ [ some-rots do-something 24-from-2 ] [ 3drop ] if-amb ;
+
+MEMO: 24-from-4 ( a b c d -- ? )
+ [ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ;
+
+: find-impossible-24 ( -- n )
+ 1 10 [a,b] [| a |
+ 1 10 [a,b] [| b |
+ 1 10 [a,b] [| c |
+ 1 10 [a,b] [| d |
+ a b c d 24-from-4
+ ] count
+ ] sigma
+ ] sigma
+ ] sigma ;
+
+: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ;
+
+: backtrack-benchmark ( -- )
+ words [ reset-memoized ] each
+ find-impossible-24 pprint "/10000 quadruples can make 24." print
+ words [
+ dup pprint " tested " write "memoize" word-prop assoc-size pprint
+ " possibilities" print
+ ] each ;
+
+MAIN: backtrack-benchmark
C[ display ] <slate> >slate
t slate> set-gadget-clipped?
- { 600 400 } slate> set-slate-dim
+ { 600 400 } slate> set-slate-pdim
C[ [ run ] in-thread ] slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft
} [ call ] map [ add-gadget ] each
1 over set-pack-fill
- over @top grid-add
+ @top grid-add*
- slate> over @center grid-add
+ slate> @center grid-add*
+
+ <handler>
H{ } clone
T{ key-down f f "1" } C[ drop randomize ] is
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
- <handler> tuck set-gadget-delegate "Boids" open-window ;
+
+ >>table
+
+ "Boids" open-window ;
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
: cfdg-window* ( -- )
[ display ] closed-quot <slate>
- { 500 500 } over set-slate-dim
+ { 500 500 } over set-slate-pdim
dup "CFDG" open-window ;
: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
\ No newline at end of file
from
] unit-test
-{ V{ 1 2 3 4 } } [
+{ { 1 2 3 4 } } [
V{ } clone <channel>
[ from swap push ] in-thread
[ from swap push ] in-thread
natural-sort
] unit-test
-{ V{ 1 2 4 9 } } [
+{ { 1 2 4 9 } } [
V{ } clone <channel>
[ 4 swap to ] in-thread
[ 2 swap to ] in-thread
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sequences sorting math math.order
-arrays combinators kernel ;
+USING: accessors assocs sequences sorting binary-search math
+math.order arrays combinators kernel ;
IN: cords
<PRIVATE
M: multi-cord virtual@
dupd
- seqs>> [ first <=> ] binsearch*
+ seqs>> [ first <=> ] with search nip
[ first - ] [ second ] bi ;
M: multi-cord virtual-seq
--- /dev/null
+
+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 ;
+
+++ /dev/null
-Doug Coleman
-Slava Pestov
Doug Coleman
+Slava Pestov
-USING: farkup kernel tools.test ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: farkup kernel peg peg.ebnf tools.test ;
IN: farkup.tests
-[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
-[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" convert-farkup ] unit-test
-[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
-[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+[ ] [
+ "abcd-*strong*\nasdifj\nweouh23ouh23"
+ "paragraph" \ farkup rule parse drop
+] unit-test
+
+[ ] [
+ "abcd-*strong*\nasdifj\nweouh23ouh23\n"
+ "paragraph" \ farkup rule parse drop
+] unit-test
-[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
[ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test
[ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test
[ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test
[ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test
[ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
-[ "" ] [ "\n\n" convert-farkup ] unit-test
-[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
-[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
-[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
-[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
+[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
+[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n</ul>" ] [ "-foo\n" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
+[ "<ul><li>foo</li>\n<li>bar</li>\n</ul>" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+
+[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+
+
+[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
+[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
+[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
+[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
+[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
-[ "<p>foo</p>
\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
[ "" ] [ "" convert-farkup ] unit-test
] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
[
- "<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+ "<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
-
-[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
-[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.styles kernel memoize namespaces peg math
-combinators sequences strings html.elements xml.entities
-xmode.code2html splitting io.streams.string peg.parsers
-sequences.deep unicode.categories ;
+USING: accessors arrays combinators html.elements io io.streams.string
+kernel math memoize namespaces peg peg.ebnf prettyprint
+sequences sequences.deep strings xml.entities vectors splitting
+xmode.code2html ;
IN: farkup
SYMBOL: relative-link-prefix
SYMBOL: disable-images?
SYMBOL: link-no-follow?
-<PRIVATE
+TUPLE: heading1 obj ;
+TUPLE: heading2 obj ;
+TUPLE: heading3 obj ;
+TUPLE: heading4 obj ;
+TUPLE: strong obj ;
+TUPLE: emphasis obj ;
+TUPLE: superscript obj ;
+TUPLE: subscript obj ;
+TUPLE: inline-code obj ;
+TUPLE: paragraph obj ;
+TUPLE: list-item obj ;
+TUPLE: list obj ;
+TUPLE: table obj ;
+TUPLE: table-row obj ;
+TUPLE: link href text ;
+TUPLE: image href text ;
+TUPLE: code mode string ;
-: delimiters ( -- string )
- "*_^~%[-=|\\\r\n" ; inline
+EBNF: farkup
+nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
+2nl = nl nl
-MEMO: text ( -- parser )
- [ delimiters member? not ] satisfy repeat1
- [ >string escape-string ] action ;
+heading1 = "=" (!("=" | nl).)+ "="
+ => [[ second >string heading1 boa ]]
-MEMO: delimiter ( -- parser )
- [ dup delimiters member? swap "\r\n=" member? not and ] satisfy
- [ 1string ] action ;
+heading2 = "==" (!("=" | nl).)+ "=="
+ => [[ second >string heading2 boa ]]
-: surround-with-foo ( string tag -- seq )
- dup <foo> swap </foo> swapd 3array ;
+heading3 = "===" (!("=" | nl).)+ "==="
+ => [[ second >string heading3 boa ]]
+
+heading4 = "====" (!("=" | nl).)+ "===="
+ => [[ second >string heading4 boa ]]
+
+strong = "*" (!("*" | nl).)+ "*"
+ => [[ second >string strong boa ]]
+
+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
-: delimited ( str html -- parser )
- [
- over token hide ,
- text [ surround-with-foo ] swapd curry action ,
- token hide ,
- ] seq* ;
-
-MEMO: escaped-char ( -- parser )
- [ "\\" token hide , any-char , ] seq* [ >string ] action ;
-
-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 ;
-
-MEMO: eq ( -- parser )
- [
- h1 ensure-not ,
- h2 ensure-not ,
- h3 ensure-not ,
- h4 ensure-not ,
- "=" token ,
- ] seq* ;
-: render-code ( string mode -- string' )
- >r string-lines r>
- [
- <pre>
- htmlize-lines
- </pre>
- ] with-string-writer ;
: invalid-url "javascript:alert('Invalid URL in farkup');" ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
-: make-link ( href text -- seq )
+: write-link ( text href -- )
escape-link
- [
- "<a" ,
- " href=\"" , >r , r> "\"" ,
- link-no-follow? get [ " nofollow=\"true\"" , ] when
- ">" , , "</a>" ,
- ] { } make ;
+ "<a" write
+ " href=\"" write write "\"" write
+ link-no-follow? get [ " nofollow=\"true\"" write ] when
+ ">" write write "</a>" write ;
-: make-image-link ( href alt -- seq )
+: write-image-link ( href text -- )
disable-images? get [
- 2drop "<strong>Images are not allowed</strong>"
+ 2drop "<strong>Images are not allowed</strong>" write
] [
escape-link
- [
- "<img src=\"" , swap , "\"" ,
- dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
- "/>" ,
- ] { } make
+ >r "<img src=\"" write write "\"" write r>
+ dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
+ "/>" write
] if ;
-MEMO: image-link ( -- parser )
- [
- "[[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 ;
-
-MEMO: simple-link ( -- parser )
- [
- "[[" token hide ,
- [ "|]" member? not ] satisfy repeat1 ,
- "]]" token hide ,
- ] seq* [ first dup make-link ] action ;
-
-MEMO: labelled-link ( -- parser )
- [
- "[[" token hide ,
- [ CHAR: | = not ] satisfy repeat1 ,
- "|" token hide ,
- [ CHAR: ] = not ] satisfy repeat1 ,
- "]]" token hide ,
- ] seq* [ first2 make-link ] action ;
-
-MEMO: link ( -- parser )
- [ image-link , simple-link , labelled-link , ] choice* ;
-
-DEFER: line
-MEMO: list-item ( -- parser )
- [
- "-" token hide , ! text ,
- [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
- ] seq* [ "li" surround-with-foo ] action ;
-
-MEMO: list ( -- parser )
- list-item nl hide list-of
- [ "ul" surround-with-foo ] action ;
-
-MEMO: table-column ( -- parser )
- text [ "td" surround-with-foo ] action ;
-
-MEMO: table-row ( -- parser )
- "|" token hide
- table-column "|" token hide list-of
- "|" token hide nl hide optional 4seq
- [ "tr" surround-with-foo ] action ;
-
-MEMO: table ( -- parser )
- table-row repeat1
- [ "table" surround-with-foo ] action ;
-
-MEMO: code ( -- parser )
- [
- "[" token hide ,
- [ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
- "{" token hide ,
- "}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
- "}]" token hide ,
- ] seq* [ first2 swap render-code ] action ;
-
-MEMO: line ( -- parser )
- [
- nl table 2seq ,
- nl list 2seq ,
- text , strong , emphasis , link ,
- superscript , subscript , inline-code ,
- escaped-char , delimiter , eq ,
- ] choice* repeat1 ;
-
-MEMO: paragraph ( -- parser )
- line
- nl over 2seq repeat0
- nl nl ensure-not 2seq optional 3seq
- [
- dup [ dup string? not swap [ blank? ] all? or ] deep-all?
- [ "<p>" swap "</p>" 3array ] unless
- ] action ;
-
-PRIVATE>
-
-PEG: parse-farkup ( -- parser )
+: render-code ( string mode -- string' )
+ >r string-lines r>
[
- 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 ;
+ <pre>
+ htmlize-lines
+ </pre>
+ ] with-string-writer write ;
+
+GENERIC: write-farkup ( obj -- )
+: <foo.> ( string -- ) <foo> write ;
+: </foo.> ( string -- ) </foo> write ;
+: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
+M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
+M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
+M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
+M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
+M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
+M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
+M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
+M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
+M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
+M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
+M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
+M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
+M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
+M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
+M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
+M: table-row write-farkup ( obj -- )
+ obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
+M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
+M: fixnum write-farkup ( obj -- ) write1 ;
+M: string write-farkup ( obj -- ) write ;
+M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
+M: f write-farkup ( obj -- ) drop ;
: convert-farkup ( string -- string' )
- parse-farkup [ write-farkup ] with-string-writer ;
+ farkup [ write-farkup ] with-string-writer ;
+
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 ;
-
-: inner ( quadric i -- )
- dup color gl-color dup radius swap center disk ;
+: rim ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ;
+: inner ( i -- ) [ color gl-color ] [ radius ] [ center ] tri disk ;
-: dot ( quadric i -- ) 2dup rim inner ;
+: dot ( i -- ) [ rim ] [ inner ] bi ;
-: 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 ] <slate>
- { 600 600 } over set-slate-dim
- "Golden Section" open-window
- ] with-ui ;
+ [ display ] <slate>
+ { 600 600 } >>pdim
+ "Golden Section" open-window
+ ]
+ with-ui ;
MAIN: golden-section-window
: $links ( topics -- )
[ [ ($link) ] textual-list ] ($span) ;
+: $vocab-links ( vocabs -- )
+ [ vocab ] map $links ;
+
: $see-also ( topics -- )
"See also" $heading $links ;
[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
-[ "<ul><li>foo</li><li>bar</li></ul>" ] [
+[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [
[ "farkup" T{ farkup } render ] with-string-writer
] unit-test
-USING: kernel sequences arrays accessors grouping\r
-math.order sorting math assocs locals namespaces ;\r
+! Copyright (C) 2008 Daniel Ehrenberg.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel sequences arrays accessors grouping math.order\r
+sorting binary-search math assocs locals namespaces ;\r
IN: interval-maps\r
\r
TUPLE: interval-map array ;\r
<PRIVATE\r
\r
: find-interval ( key interval-map -- interval-node )\r
- [ first <=> ] binsearch* ;\r
+ [ first <=> ] with search nip ;\r
\r
: interval-contains? ( key interval-node -- ? )\r
first2 between? ;\r
! 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
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+
<mailbox> <mailbox> irc-server-listener boa ;
: <irc-channel-listener> ( name -- irc-channel-listener )
- <mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
+ [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ;
: <irc-nick-listener> ( name -- irc-nick-listener )
- <mailbox> <mailbox> rot irc-nick-listener boa ;
+ [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
! ======================================
! Message objects
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 ;
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 ;
: /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
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 ;
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 ;
! ======================================
! ======================================
: 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 -- )
: (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 ;
{
{ [ dup string? ] [ strings>privmsg ] }
{ [ dup privmsg instance? ] [ swap >>name ] }
+ [ nip ]
} cond ;
: listener-loop ( name 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 -- )
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 -- )
[ 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>
! 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 ;
TUPLE: nick-in-use < irc-message asterisk name ;
TUPLE: notice < irc-message type ;
TUPLE: mode < irc-message name channel mode ;
+TUPLE: names-reply < irc-message who = channel ;
TUPLE: unhandled < irc-message ;
+GENERIC: irc-message>client-line ( irc-message -- string )
+
+M: irc-message irc-message>client-line ( irc-message -- string )
+ [ command>> ]
+ [ parameters>> " " sjoin ]
+ [ trailing>> dup [ CHAR: : prefix ] when ]
+ tri 3array " " sjoin ;
+
+GENERIC: irc-message>server-line ( irc-message -- string )
+M: irc-message irc-message>server-line ( irc-message -- string )
+ drop "not implemented yet" ;
+
<PRIVATE
! ======================================
! Message parsing
{ "NOTICE" [ \ notice ] }
{ "001" [ \ logged-in ] }
{ "433" [ \ nick-in-use ] }
+ { "353" [ \ names-reply ] }
{ "JOIN" [ \ join ] }
{ "PART" [ \ part ] }
{ "PRIVMSG" [ \ privmsg ] }
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel vocabs.loader sequences strings splitting words irc.messages ;\r
+\r
+IN: irc.ui.commandparser\r
+\r
+"irc.ui.commands" require\r
+\r
+: command ( string string -- string command )\r
+ dup empty? [ drop "say" ] when\r
+ dup "irc.ui.commands" lookup\r
+ [ nip ]\r
+ [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;\r
+\r
+: parse-message ( string -- )\r
+ "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel irc.client irc.messages irc.ui namespaces ;\r
+\r
+IN: irc.ui.commands\r
+\r
+: say ( string -- )\r
+ [ client get profile>> nickname>> <own-message> print-irc ]\r
+ [ listener get write-message ] bi ;\r
+\r
+: quote ( string -- )\r
+ drop ; ! THIS WILL CHANGE\r
--- /dev/null
+! Default system ircui-rc file\r
+! Copy into .ircui-rc in your home directory and then change username and such\r
+! To find your home directory, type "home ." into a Factor listener\r
+\r
+USING: irc.client irc.ui ;\r
+\r
+"irc.freenode.org" 8001 "factor-irc" f ! server port nick password\r
+{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin\r
+server-open\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel io.files parser editors sequences ;\r
+\r
+IN: irc.ui.load\r
+\r
+: file-or ( path path -- path ) over exists? ? ;\r
+\r
+: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
+\r
+: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;\r
+\r
+: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;\r
+\r
+: run-ircui ( -- ) ircui-rc run-file ;\r
\r
USING: accessors kernel threads combinators concurrency.mailboxes\r
sequences strings hashtables splitting fry assocs hashtables\r
- ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers\r
- ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs\r
- io io.styles namespaces irc.client irc.messages ;\r
+ ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
+ ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
+ ui.gadgets.tabs ui.gadgets.grids\r
+ io io.styles namespaces calendar calendar.format\r
+ irc.client irc.client.private irc.messages irc.messages.private\r
+ irc.ui.commandparser irc.ui.load ;\r
\r
IN: irc.ui\r
\r
+SYMBOL: listener\r
+\r
SYMBOL: client\r
\r
TUPLE: ui-window client tabs ;\r
: green { 0 0.5 0 1 } ;\r
: blue { 0 0 1 1 } ;\r
\r
-: prefix>nick ( prefix -- nick )\r
- "!" split first ;\r
+: dot-or-parens ( string -- string )\r
+ dup empty? [ drop "." ]\r
+ [ "(" prepend ")" append ] if ;\r
\r
GENERIC: write-irc ( irc-message -- )\r
\r
M: privmsg write-irc\r
"<" blue write-color\r
- [ prefix>> prefix>nick write ] keep\r
- ">" blue write-color\r
- " " write\r
+ [ prefix>> parse-name write ] keep\r
+ "> " blue write-color\r
trailing>> write ;\r
\r
+TUPLE: own-message message nick timestamp ;\r
+\r
+: <own-message> ( message nick -- own-message )\r
+ now own-message boa ;\r
+\r
+M: own-message write-irc\r
+ "<" blue write-color\r
+ [ nick>> bold font-style associate format ] keep\r
+ "> " blue write-color\r
+ message>> write ;\r
+\r
M: join write-irc\r
"* " green write-color\r
- prefix>> prefix>nick write\r
+ prefix>> parse-name write\r
" has entered the channel." green write-color ;\r
\r
M: part write-irc\r
"* " red write-color\r
- [ prefix>> prefix>nick write ] keep\r
- " has left the channel(" red write-color\r
- trailing>> write\r
- ")" red write-color ;\r
+ [ prefix>> parse-name write ] keep\r
+ " has left the channel" red write-color\r
+ trailing>> dot-or-parens red write-color ;\r
\r
M: quit write-irc\r
"* " red write-color\r
- [ prefix>> prefix>nick write ] keep\r
- " has left IRC(" red write-color\r
- trailing>> write\r
- ")" red write-color ;\r
+ [ prefix>> parse-name write ] keep\r
+ " has left IRC" red write-color\r
+ trailing>> dot-or-parens red write-color ;\r
\r
M: irc-end write-irc\r
drop "* You have left IRC" red write-color ;\r
drop ; ! catch all unimplemented writes, THIS WILL CHANGE \r
\r
: print-irc ( irc-message -- )\r
- write-irc nl ;\r
+ [ timestamp>> timestamp>hms write " " write ]\r
+ [ write-irc nl ] bi ;\r
\r
-: send-message ( message listener client -- )\r
- "<" blue write-color\r
- profile>> nickname>> bold font-style associate format\r
- ">" blue write-color\r
- " " write\r
- over write nl\r
- out-messages>> mailbox-put ;\r
+: send-message ( message -- )\r
+ [ print-irc ]\r
+ [ listener get write-message ] bi ;\r
\r
: display ( stream listener -- )\r
'[ , [ [ t ]\r
\r
TUPLE: irc-editor < editor outstream listener client ;\r
\r
-: <irc-editor> ( pane listener client -- editor )\r
- [ irc-editor new-editor\r
+: <irc-editor> ( page pane listener -- client editor )\r
+ irc-editor new-editor\r
swap >>listener swap <pane-stream> >>outstream\r
- ] dip client>> >>client ;\r
+ over client>> >>client ;\r
\r
: editor-send ( irc-editor -- )\r
{ [ outstream>> ]\r
- [ editor-string ]\r
[ listener>> ]\r
[ client>> ]\r
+ [ editor-string ]\r
[ "" swap set-editor-string ] } cleave\r
- '[ , , , send-message ] with-output-stream ;\r
+ '[ , listener set , client set , parse-message ] with-output-stream ;\r
\r
irc-editor "general" f {\r
{ T{ key-down f f "RET" } editor-send }\r
{ T{ key-down f f "ENTER" } editor-send }\r
} define-command-map\r
\r
-: irc-page ( name pane editor tabbed -- )\r
- [ [ <scroller> @bottom frame, ! editor\r
- <scroller> @center frame, ! pane\r
- ] make-frame swap ] dip add-page ;\r
+TUPLE: irc-page < frame listener client ;\r
+\r
+: <irc-page> ( listener client -- irc-page )\r
+ irc-page new-frame\r
+ swap client>> >>client swap [ >>listener ] keep\r
+ [ <irc-pane> [ <scroller> @center grid-add* ] keep ]\r
+ [ <irc-editor> <scroller> @bottom grid-add* ] bi ;\r
+\r
+M: irc-page graft*\r
+ [ listener>> ] [ client>> ] bi\r
+ add-listener ;\r
+\r
+M: irc-page ungraft*\r
+ [ listener>> ] [ client>> ] bi\r
+ remove-listener ;\r
\r
: join-channel ( name ui-window -- )\r
[ dup <irc-channel-listener> ] dip\r
- [ client>> add-listener ]\r
- [ drop <irc-pane> dup ]\r
- [ [ <irc-editor> ] keep ] 2tri\r
- tabs>> irc-page ;\r
+ [ <irc-page> swap ] keep\r
+ tabs>> add-page ;\r
\r
: irc-window ( ui-window -- )\r
[ tabs>> ]\r
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>\r
"Server" associate <tabbed> >>tabs ] bi ;\r
\r
-: freenode-connect ( -- ui-window )\r
- "irc.freenode.org" 8001 "factor-irc" f\r
- <irc-profile> ui-connect [ irc-window ] keep ;\r
+: server-open ( server port nick password channels -- )\r
+ [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
+ [ over join-channel ] each ;\r
+\r
+: main-run ( -- ) run-ircui ;\r
+\r
+MAIN: main-run\r
: lsys-viewer ( -- )
[ ] <slate> >slate
-{ 400 400 } clone slate> set-slate-dim
+{ 400 400 } clone slate> set-slate-pdim
+
+slate> <handler>
{
[ [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
camera-action ] }
-! } [ make* ] map alist>hash <handler> >handler
-
-} [ make* ] map >hashtable <handler> >handler
-
-slate> handler> set-gadget-delegate
+} [ make* ] map >hashtable >>table
-handler> "L-system view" open-window
+"L-system view" open-window
500 sleep
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel lists.lazy math math.functions math.miller-rabin
- math.order math.primes.list math.ranges sequences sorting ;
+ math.order math.primes.list math.ranges sequences sorting
+ binary-search ;
IN: math.primes
<PRIVATE
: 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
{
{ [ dup 2 < ] [ drop { } ] }
{ [ dup 1000003 < ]
- [ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep <slice> ] }
+ [ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice> ] }
[ primes-under-million 1000003 lprimes-from
rot [ <= ] curry lwhile list>array append ]
} cond ; foldable
: primes-between ( low high -- seq )
primes-upto
[ 1- next-prime ] dip
- [ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
+ [ natural-search drop ] keep [ length ] keep <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
{ { object ppc object } "b" }
{ { string object windows } "c" }
}
- V{ cpu os }
+ { cpu os }
] [
example-1 canonicalize-specializers
] unit-test
] unit-test
[
- "USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop
+ "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
] must-fail
{ t } [
{ "\\" } [
"\\" [EBNF foo="\\" EBNF]
-] unit-test
\ No newline at end of file
+] unit-test
M: ebnf-rule (transform) ( ast -- parser )\r
dup elements>> \r
(transform) [\r
- swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [ \r
+ swap symbol>> dup get parser? [ \r
"Rule '" over append "' defined more than once" append throw \r
] [ \r
set \r
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 ;
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: set-gadget-delegate ( tuple gadget -- tuple )
- over ui.gadgets:set-gadget-delegate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
-: <processing-gadget> ( -- gadget )
- processing-gadget new
- <frame-buffer> set-gadget-delegate ;
+: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
500 sleep
<processing-gadget>
- size-val get >>dim
+ size-val get >>pdim
dup "Processing" open-window
500 sleep
--- /dev/null
+
+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
USING: soundex tools.test ;
[ "S162" ] [ "supercalifrag" soundex ] unit-test
+[ "M000" ] [ "M" soundex ] unit-test
[ first>upper ]
[
soundex-tr
- trim-first
- remove-duplicates
+ [ "" ] [ trim-first ] if-empty
+ [ "" ] [ remove-duplicates ] if-empty
remove-zeroes
] bi
pad-4
: springies-window* ( -- )
C[ display ] <slate> >slate
- { 800 600 } slate> set-slate-dim
+ { 800 600 } slate> set-slate-pdim
C[ { 500 500 } >world-size loop on [ run ] in-thread ]
slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft
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 )
] 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 ;
: 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 -- )
: 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
-: <book> ( pages model -- book )
- book new-book ;
+: <book> ( pages model -- book ) book new-book ;
-M: book pref-dim* gadget-children pref-dims max-dim ;
+M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
-M: book layout*
- dup rect-dim swap gadget-children
- [ set-layout-dim ] with each ;
+M: book layout* ( book -- )
+ [ dim>> ] [ children>> ] bi [ set-layout-dim ] with each ;
-M: book focusable-child* current-page ;
+M: book focusable-child* ( book -- child/t ) current-page ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
+TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: <frame-buffer> ( -- frame-buffer )
- frame-buffer construct-gadget
+: new-frame-buffer ( class -- gadget )
+ new-gadget
[ ] >>action
- { 100 100 } >>dim
+ { 100 100 } >>pdim
[ ] >>graft
[ ] >>ungraft ;
+: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: draw-pixels ( fb -- fb )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-M: frame-buffer pref-dim* dim>> ;
+M: frame-buffer pref-dim* pdim>> ;
M: frame-buffer graft* graft>> call ;
M: frame-buffer ungraft* ungraft>> call ;
{ $subsection frame }
"Creating empty frames:"
{ $subsection <frame> }
-"Creating new frames using a combinator:"
-{ $subsection frame, }
-"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
+"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add* } ":"
{ $subsection @center }
{ $subsection @left }
{ $subsection @right }
: $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 ;
HELP: frame
{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
$nl
-"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
+"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add* } " and " { $link grid-remove } "." } ;
HELP: <frame>
{ $values { "frame" frame } }
{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
-HELP: frame,
-{ $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } }
-{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to make-frame." } ;
-
{ grid frame } related-words
ABOUT: "ui-frame-layout"
dup compute-grid
[ rot rect-dim fill-center ] 3keep
grid-layout ;
-
-: frame, ( gadget i j -- )
- gadget get -rot grid-add ;
! 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
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 -- ? )
[ focus>> ] follow ;
! Deprecated
-: set-gadget-delegate ( gadget tuple -- )
- over [
- dup pick [ (>>parent) ] with each-child
- ] when set-delegate ;
: construct-gadget ( class -- tuple )
>r <gadget> { set-delegate } r> construct ; inline
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
-{ $subsection grid-add }
+{ $subsection grid-add* }
{ $subsection grid-remove }
{ $subsection grid-child } ;
$nl
"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
$nl
-"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
+"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add* } " and " { $link grid-remove } "."
$nl
"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
{ $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" } ;
: 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 <gadget> r> r> r> grid-add ;
+: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add* ;
: pref-dim-grid ( grid -- dims )
grid>> [ [ pref-dim ] map ] map ;
-USING: kernel assocs ui.gestures ;
+USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
IN: ui.gadgets.handler
-TUPLE: handler table ;
+TUPLE: handler < wrapper table ;
-C: <handler> handler
+: <handler> ( child -- handler ) handler new-wrapper ;
M: handler handle-gesture* ( gadget gesture delegate -- ? )
-handler-table at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
+ table>> at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
! 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? ;
-
-: clear-selection ( pane -- )
- f >>caret
- f >>mark
- drop ;
+ output current prototype scrolls?
+ selection-color caret mark selecting? ;
-: add-output ( current pane -- )
- [ set-pane-output ] [ swap add-gadget drop ] 2bi ;
+: clear-selection ( pane -- pane ) f >>caret f >>mark ;
-: add-current ( current pane -- )
- [ set-pane-current ] [ swap add-gadget drop ] 2bi ;
+: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
+: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
-: prepare-line ( pane -- )
- [ clear-selection ]
- [ [ pane-prototype clone ] keep add-current ] bi ;
+: prepare-line ( pane -- pane )
+ clear-selection
+ dup prototype>> clone add-current ;
-: 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
<shelf> >>prototype
- <incremental> over add-output
- dup prepare-line
- pane-theme ;
+ <incremental> add-output
+ prepare-line
+ selection-color >>selection-color ;
-: <pane> ( -- pane )
- pane new-pane ;
+: <pane> ( -- pane ) pane new-pane ;
GENERIC: draw-selection ( loc obj -- )
: 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 ;
TUPLE: pane-control < pane quot ;
-M: pane-control model-changed
- swap model-value swap dup pane-control-quot with-pane ;
+M: pane-control model-changed ( model pane-control -- )
+ [ value>> ] [ dup quot>> ] bi* with-pane ;
: <pane-control> ( model quot -- pane )
pane-control new-pane
>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 ;
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 ;
[ 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
] 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 ;
-USING: kernel namespaces opengl ui.render ui.gadgets ;
+USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
IN: ui.gadgets.slate
-TUPLE: slate action dim graft ungraft
- button-down
- button-up
- key-down
- key-up ;
+TUPLE: slate < gadget action pdim graft ungraft ;
: <slate> ( action -- slate )
- slate construct-gadget
- tuck set-slate-action
- { 100 100 } over set-slate-dim
- [ ] over set-slate-graft
- [ ] over set-slate-ungraft ;
+ slate new-gadget
+ swap >>action
+ { 100 100 } >>pdim
+ [ ] >>graft
+ [ ] >>ungraft ;
-M: slate pref-dim* ( slate -- dim ) slate-dim ;
+M: slate pref-dim* ( slate -- dim ) pdim>> ;
-M: slate draw-gadget* ( slate -- )
- origin get swap slate-action with-translation ;
+M: slate draw-gadget* ( slate -- ) origin get swap action>> with-translation ;
-M: slate graft* ( slate -- ) slate-graft call ;
+M: slate graft* ( slate -- ) graft>> call ;
+M: slate ungraft* ( slate -- ) ungraft>> call ;
-M: slate ungraft* ( slate -- ) slate-ungraft call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: key-pressed-value
-
-: key-pressed? ( -- ? ) key-pressed-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: mouse-pressed-value
-
-: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: key-value
-
-: key ( -- key ) key-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: button-value
-
-: button ( -- val ) button-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: combinators ui.gestures accessors ;
-
-! M: slate handle-gesture* ( gadget gesture delegate -- ? )
-! drop nip
-! {
-! {
-! [ dup key-down? ]
-! [
-
-! key-down-sym key-value set
-! key-pressed-value on
-! t
-! ]
-! }
-! { [ dup key-up? ] [ drop key-pressed-value off t ] }
-! {
-! [ dup button-down? ]
-! [
-! button-down-# mouse-button-value set
-! mouse-pressed-value on
-! t
-! ]
-! }
-! { [ dup button-up? ] [ drop mouse-pressed-value off t ] }
-! { [ t ] [ drop t ] }
-! }
-! cond ;
-
-M: slate handle-gesture* ( gadget gesture delegate -- ? )
- rot drop swap ! delegate gesture
- {
- {
- [ dup key-down? ]
- [
- key-down-sym key-value set
- key-pressed-value on
- key-down>> dup [ call ] [ drop ] if
- t
- ]
- }
- {
- [ dup key-up? ]
- [
- key-pressed-value off
- drop
- key-up>> dup [ call ] [ drop ] if
- t
- ] }
- {
- [ dup button-down? ]
- [
- button-down-# button-value set
- mouse-pressed-value on
- button-down>> dup [ call ] [ drop ] if
- t
- ]
- }
- {
- [ dup button-up? ]
- [
- mouse-pressed-value off
- drop
- button-up>> dup [ call ] [ drop ] if
- t
- ]
- }
- { [ t ] [ 2drop t ] }
- }
- cond ;
\ No newline at end of file
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
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 ;
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
{ T{ button-down } [ elevator-click ] }
} set-gestures
-: elevator-theme ( elevator -- )
- lowered-gradient swap set-gadget-interior ;
-
: <elevator> ( vector -- elevator )
- elevator new-gadget
- [ set-gadget-orientation ] keep
- dup elevator-theme ;
+ elevator new-gadget
+ swap >>orientation
+ lowered-gradient >>interior ;
: (layout-thumb) ( slider n -- n thumb )
over gadget-orientation n*v swap slider-thumb ;
dup elevator>> over thumb>> add-gadget
@center grid-add* ;
-: <left-button> ( -- button )
- { 0 1 } arrow-left -1 <slide-button> ;
-
-: <right-button> ( -- button )
- { 0 1 } arrow-right 1 <slide-button> ;
-
-: <up-button> ( -- button )
- { 1 0 } arrow-up -1 <slide-button> ;
-
-: <down-button> ( -- button )
- { 1 0 } arrow-down 1 <slide-button> ;
+: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
+: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
+: <up-button> ( -- button ) { 1 0 } arrow-up -1 <slide-button> ;
+: <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ;
: <slider> ( range orientation -- slider )
slider new-frame
[ clear-track ]
[
dup ref>> <slot-editor>
- [ swap 1 track-add ]
+ [ 1 track-add* drop ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ;
: open-status-window ( gadget title -- )
f <model> [ <world> ] keep
- <status-bar> over f track-add
+ <status-bar> f track-add*
open-world-window ;
: show-summary ( object gadget -- )
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
-{ $subsection track-add } ;
+{ $subsection track-add* } ;
HELP: track
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
{ $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." } ;
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 ;
{ 0 0 } >>window-loc
swap >>status
swap >>title
- [ 1 track-add ] keep
+ swap 1 track-add*
dup request-focus ;
M: world layout*
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ui.gadgets kernel ;
+
IN: ui.gadgets.wrappers
TUPLE: wrapper < gadget ;
-: new-wrapper ( child class -- wrapper )
- new-gadget
- [ swap add-gadget drop ] keep ; inline
+: new-wrapper ( child class -- wrapper ) new-gadget swap add-gadget ;
-: <wrapper> ( child -- border )
- wrapper new-wrapper ;
+: <wrapper> ( child -- border ) wrapper new-wrapper ;
-M: wrapper pref-dim*
- gadget-child pref-dim ;
+M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
-M: wrapper layout*
+M: wrapper layout* ( wrapper -- )
[ dim>> ] [ gadget-child ] bi set-layout-dim ;
-M: wrapper focusable-child*
- gadget-child ;
+M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;
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 ] <closable-gadget>
! 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
] with with filter ;
: find-zip-code ( code -- city )
- cities [ first-zip>> <=> ] binsearch* ;
+ cities [ first-zip>> <=> ] with search nip ;
projects / factor.git / commitdiff